home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 126-150 / disk_143 / rim / rimsrcami.arc / Rim.for < prev    next >
Text File  |  1988-03-22  |  567KB  |  23,722 lines
  1.       PROGRAM RMMAIN (Tape=24,err=1)
  2. C
  3. C  ****************************************************************
  4. C
  5. C  RELATIONAL INFORMATION MANAGEMENT SYSTEM (RIM) - VERSION 5
  6. C
  7. C  THIS PROGRAM IS AN IMPLEMENTATION OF THE RELATIONAL ALGEBRA
  8. C  MODEL OF DATA BASE MANAGEMENT.
  9. C
  10. C  THE PRINCIPAL AUTHORS ARE
  11. C
  12. C  WAYNE J. ERICKSON
  13. C    DATA MANAGEMENT CONSULTANT
  14. C    2029 5TH STREET S.E.
  15. C    PUYALLUP,WASHINGTON 98371
  16. C  FREDERIC P. GRAY JR.
  17. C    BOEING COMERCIAL AIRPLANE COMPANY (BCAC)
  18. C  GEOFFREY VONLIMBACH
  19. C    BOEING COMPUTER SERVICES COMPANY (BCS)
  20. C
  21. C  CONTRIBUTIONS TO RIM-5 CODE WERE ALSO MADE BY
  22. C
  23. C  LAURA B. HAMED (UNLOAD) AND
  24. C  STIG O. WAHLSTROM (SORT) OF BCS AND BCAC RESPECTIVELY.
  25. C
  26. C  RIM-5 EXTENDS THE CAPABILITIES OF RIM-4
  27. C  PRIMARILY BY ADDING CAPABILITY FOR VARIABLE LENGTH
  28. C  ATTRIBUTES,ADDING SEVERAL ATTRIBUTE TYPES,IMPLEMENTING
  29. C  BOTH DIRECT AND MENU MODE,EXPANDING THE COMMAND LANGUAGE
  30. C  AND ENTENDING THE FORTRAN INTERFACE CAPABILITIES
  31. C
  32. C  RIM-5 IS WRITTEN IN FORTRAN 77 AND IS INTENDED TO
  33. C  BE EASILY IMPLEMENTED ON COMPUTERS SUPPORTING THIS
  34. C  LANGUAGE.
  35. C
  36. C  RIM WAS ORIGINALLY DEVELOPED UNDER THE IPAD PROJECT
  37. C  (NASA CONTRACT NAS-14700) BY WAYNE ERICKSON AND
  38. C  DENNIS COMFORT BOTH AT THAT TIME WITH BCS. EXTENSIONS
  39. C  TO RIM WERE THEN MADE BY WAYNE ERICKSON AND FRED GRAY
  40. C  RESULTING IN VERSION 4 (RIM-4) IN LATE 1980.
  41. C  IT WAS LATER PORTED TO 8088 (MS FORTRAN) IN 1985 BY GCE
  42. C  FOR USE ANYWHERE A REASONABLE FORTRAN 77 DIALECT WAS
  43. C  DESIRED. THIS PORT HAD TO CONTEND WITH A COMPILER WHICH
  44. C  DID NOT SUPPORT HOLLERITH DATA AND WHICH HAD SERIOUS
  45. C  RESTRICTIONS IN ASSIGNMENTS BETWEEN CHARACTER AND
  46. C  INTEGER DATA, AND WHICH HAD NO SINGLE BYTE DATA TYPE
  47. C  OTHER THAN CHARACTER*1.
  48. C  The 8088 port was further ported to Amiga in 1988 by GCE
  49. C  where the Fortran compiler was more robust but the OS
  50. C  supported windows etc... The DBMS is set up to use the
  51. C  parent window for default I/O (closest thing to vanilla
  52. C  Fortran-ish I/O available on Amiga Fortran) but the code is
  53. C  otherwise changed as little as possible from the MS Fortran
  54. C  code. This allows somewhat brain-damaged compilers in the
  55. C  future to have hope of dealing with it. Even though the Amiga
  56. C  compiler may support the Hollerith data type, I prefer using
  57. C  the newer character types as done herein.  All I/O is done
  58. C  using "ordinary" Fortrash I/O, so this program is a bit of a
  59. C  pig. Also, the user is WARNED: don't let two people both use
  60. C  RIM on the same database at the same time unless you've got it
  61. C  WELL backed up. Depending on how well the host OS locks records,
  62. C  RIM can either work fine, or totally corrupt the database.
  63. C
  64. C  MAJOR MILESTONES IN THE DEVELOPMENT OF RIM:
  65. C
  66. C     1/78 TO 3/78 - WAYNE ERICKSON AND DENNIS COMFORT DEVELOP
  67. C                    VERSION 1 OF RIM AS PART OF THE IPAD PROJECT
  68. C     4/78 TO 9/78 - WAYNE AND DENNIS MAKE FURTHER ENHANCEMENTS TO
  69. C                    MAKE VERSION 2 WHILE AT IPAD
  70. C     6/79 TO 9/79 - WAYNE MAKES VERSION 3 OF RIM AT THE UNIVERSITY
  71. C                    OF WASHINGTON. THIS VERSION USED THE CDC
  72. C                    SEGMENTED LOADER AND THE FASTIO PACKAGE.
  73. C     9/79 TO 5/80 - WAYNE MAKES VERSION 4 OF RIM FOR THE UNIVERSITY
  74. C                    OF WASHINGTON AND BOEING/NASA. THIS VERSION COULD
  75. C                    HANDLE RELATIONS OF ANY LENGTH AND HAD KEY ELEMENTS
  76. C     5/80 TO 1/81 - FRED GRAY EXTENDS VERSION 4 AT BOEING TO INCLUDE
  77. C                    AN ENHANCED COMMAND LANGUAGE AND A MENU MODE OF
  78. C                    EXECUTION.
  79. C     9/80 TO 1/81 - WAYNE DEVELOPES A VAX VERSION OF RIM BASED ON THE
  80. C                    CDC VERSION.
  81. C     2/81 TO 9/81 - WAYNE TOGETHER WITH JEFF VON LIMBACH AND FRED GRAY
  82. C                    OF BOEING DEVELOP THE RIM PORTABLE VERSION (RIM-5).
  83. C
  84. C  ****************************************************************
  85. C
  86. C  RIM IS SUBJECT TO THE RESTRICTIONS AND DISCLAIMERS LISTED BELOW.
  87. C
  88. C  RESTRICTIONS AND DISCLAIMERS
  89. C
  90. C  THIS SOFTWARE IS PROVIDED BY THE BOEING COMPANY UNDER NASA CONTRACT
  91. C  NAS1-14700 (IPAD).  BOEING DEVELOPED AND/OR DISTRIBUTED IPAD SOFTWARE
  92. C  AND DOCUMENTATION MAY BE USED BY AUTHORIZED RECIPIENTS SUBJECT TO THE
  93. C  FOLLOWING LEGENDS.
  94. C
  95. C   BECAUSE OF ITS POSSIBLE COMMERCIAL VALUE, THIS DATA DEVELOPED
  96. C   UNDER U.S. GOVERNMENT CONTRACT NAS1-14700 IS BEING DISSEMINATED
  97. C   WITHIN THE U.S. IN ADVANCE OF GENERAL PUBLICATION.  THIS DATA MAY
  98. C   BE DUPLICATED AND USED BY THE RECIPIENT WITH THE EXPRESSED LIMIT-
  99. C   ATIONS THAT THE DATA WILL NOT BE PUBLISHED NOR WILL IT BE RELEASED
  100. C   TO FOREIGN PARTIES WITHOUT PRIOR PERMISSION OF THE BOEING COMPANY.
  101. C   RELEASE OF THIS DATA TO OTHER DOMESTIC PARTIES BY THE RECIPIENT
  102. C   SHALL ONLY BE MADE SUBJECT TO THESE LIMITATIONS.  THE LIMITATIONS
  103. C   CONTAINED IN THIS LEGEND WILL BE CONSIDERED VOID AFTER OCT. 15,
  104. C   1985.  THIS LEGEND SHALL BE MARKED ON ANY REPRODUCTION OF THIS
  105. C   DATA IN WHOLE OR IN PART.
  106. C
  107. C   BY ACCEPTANCE OF AND IN CONSIDERATION OF THE RECEIPT OF THE DOCU-
  108. C   MENT, DATA, OR SOFTWARE, PRODUCED BY THE BOEING COMPANY (BOEING)
  109. C   UNDER NATIONAL AERONAUTICS AND SPACE ADMINISTRATION (NASA) DEVEL-
  110. C   OPMENT CONTRACT NO. NAS1-14700 (IPAD), THE THIRD PARTY RECIPIENT,
  111. C   ITS SUCCESSORS AND ASSIGNS AGREE AS FOLLOWS:
  112. C
  113. C      DISTRIBUTION OF THIS SOFTWARE (INCLUDING RELATED DATA AND
  114. C      OTHER DOCUMENTATION) IS MADE BY BOEING ONLY AS AN
  115. C      ACCOMODATION TO NASA. THIS SOFTWARE IS PROVIDED TO ALL
  116. C      RECIPIENTS IN AN "AS IS" CONDITION. IN CONSIDERATION OF
  117. C      RECEIPT OF THIS SOFTWARE, THE REQUESTOR AND ANY SUBSEQUENT
  118. C      RECIPIENT ("RECIPIENT" HEREIN), AND THEIR SUCCESSORS AND
  119. C      ASSIGNS, AGREE AS FOLLOWS:  THE BOEING COMPANY MAKES NO
  120. C      WARRANTY WHATSOEVER IN CONNECTION WITH THIS SOFTWARE, AND THE
  121. C      RECIPIENT HEREBY WAIVES, RELEASES AND RENOUNCES ALL
  122. C      WARRANTIES,GUARANTEES, OBLIGATIONS, LIABILITIES, RIGHTS AND
  123. C      REMEDIES, EXPRESS OR IMPLIED, ARISING BY LAW, CONTRACT OR
  124. C      OTHERWISE WITH RESPECT TO SUCH SOFTWARE. THE RECIPIENT SHALL
  125. C      INCLUDE VERBATIM THE ENTIRE CONTENTS OF THIS DISCLAIMER,
  126. C      INCLUDING THIS SENTENCE, WITH ANY AND ALL COPIES OF THIS
  127. C      SOFTWARE WHICH IS PROVIDED TO ANY OTHER RECIPIENT.
  128. C
  129. C  ****************************************************************
  130. C
  131. C  PURPOSE: THIS PROGRAM CONTROLS THE TWO MAIN BRANCHES OF THE
  132. C           RIM SYSTEM -- MENU AND COMMAND. IF THE USER
  133. C           SELECTS THE MENU MODE, CONTROL IS PASSED TO THE
  134. C           SUBROUTINE INTCON, IF THE COMMAND MODE IS SELECTED CONTROL
  135. C           IS PASSED TO THE SUBROUTINE RIM. UPON AN "EXIT" THE
  136. C           RETURNING AND/OR REPLACING OF THE DATABASE FILES IS
  137. C           HANDLED BY MACHINE DEPENDENT ROUTINES, IE CDCPUT.
  138. C
  139.         Include CONST4.BLK
  140.         Include CONST8.BLK
  141.         Include RMKEYW.BLK
  142.         Include CDCDBS.BLK
  143.         Include FLAGS.BLK
  144.         Include FILES.BLK
  145.         Include SELCOM.BLK
  146.         Include DCLAR6.BLK
  147.         Include PTRCOM.BLK
  148.     Include RIMCOM.BLK
  149.       LOGICAL TTY
  150.       INTEGER VER
  151.       INTEGER UDXX
  152.       INTEGER MACH(2)
  153.     CHARACTER*4 CVER,CUDXX,CMACH(2)
  154.     EQUIVALENCE(CMACH(1),MACH(1)),(CVER,VER),(CUDXX,UDXX)
  155.       DATA CVER /'5.1M'/
  156.       DATA CUDXX /'FT68'/
  157.       DATA CMACH(1),CMACH(2) /'---A','miga'/
  158. C 8088 VERSION FOR MS FORTRAN BY GCE 7/1985
  159. C Amiga version be GCE, 1988
  160. C
  161. CBCS **** START
  162. C
  163. C  INITIALIZE - BATCH SHOULD BE FALSE ON OTHER MACHINES
  164.     RMSTAT=0
  165. C
  166. C 8088 DATA SETUP FOR RMSAV,ETC
  167.     NEXPOS=0
  168.     NEXPOT=0
  169.     DO 2 K=1,2
  170.     DO 2 NUMOPN=1,10
  171. 2    SAVBLK(K,NUMOPN)=0
  172. C END 8088 SPECIAL...
  173.       NUMOPN = 0
  174.       BATCH = .FALSE.
  175.       K = 0
  176.       IF(.NOT.TTY(K)) BATCH = .TRUE.
  177. C
  178. CBCS **** END
  179. C
  180. C  OPEN THE INPUT AND OUTPUT FILES AND INITIALIZE
  181. C
  182.       NINT = 9
  183.       NOUT = 9
  184.       NOUTR = 9
  185. C OPEN CONSOLE ON 8088
  186. C ASSUME CONSOLE NAME IS "CON:"
  187. C
  188. C GCE 7/85
  189. C No need for open on lun 9 since that's parent window on Amiga
  190. c    OPEN(NINT,FILE='CON:')
  191. c    OPEN(NOUT,FILE='CON:')
  192. C 5 IS INPUT, 6 IS OUTPUT. SINCE THESE ARE NOT OPENED BY DEFAULT,
  193. C DO IT HERE. MACHINE DEPENDENT AND OS DEPENDENT CODE, SO MODIFY
  194. C THE NAME IF YOUR MACHINE DIFFERS.
  195.       CALL LXCONS
  196.     WRITE(9,15)
  197. 15    FORMAT(' RIM relational DBMS for AMIGA starting...')
  198.     Write(9,16)
  199. 16    Format(' Compiled by Absoft Fortran 2.3')
  200.       CALL RMSTRT
  201.       CALL SETIN(K8IN)
  202.       CALL SETOUT(K8OUT)
  203.       ULPP = 0
  204.       UMCPL = 0
  205.       INTOPT = 0
  206.       NEXTOP = K8BEGI
  207.       ECHO = .FALSE.
  208.       CALL LXSET(KWECHO,K4OFF)
  209.       IF(.NOT.BATCH) GO TO 50
  210.       ECHO = .TRUE.
  211. C
  212.       CALL LXSET(KWECHO,K4ON)
  213.    50 CONTINUE
  214. C
  215. C  GET THE DATE AND TIME
  216. C
  217.       CALL RMDATE(IDAY)
  218.       CALL RMTIME(ITIME)
  219. C
  220. C  SET THE PROMPT CHARACTER - CDC ONLY
  221. C
  222. CBCS **** START
  223. C
  224.       CALL LXSET(K4PROM,K4RP)
  225. C
  226. CBCS **** END
  227. C
  228. C  SET THE VERSION AND UPDATE IDENTIFIER
  229. C
  230. C
  231. C  PRINT THE RIM EXECUTION HEADER
  232. C
  233.       WRITE(NOUT,100) MACH(1),MACH(2),VER,UDXX,IDAY,ITIME
  234.   100 FORMAT(1X,'BEGIN RIM -',2A4,8H VERSION,1X,A3,
  235.      1       3X,A4,10X,A8,4X,A8)
  236. C
  237. C  EXECUTION OPTION IS COMMAND BY DEFAULT - PRINT MESSAGE
  238. C
  239.       IF(BATCH) GO TO 500
  240.       IF(.NOT.CONNI) GO TO 500
  241.       WRITE(NOUT,200)
  242.   200 FORMAT(1X,16HRIM COMMAND MODE,/,
  243.      X         1X,26HENTER "MENU" FOR MENU MODE,/)
  244.       GO TO 500
  245. C
  246. C  ****************************************************************
  247. C
  248. C             I N T E R A C T I V E      S E C T I O N
  249. C
  250. C  ****************************************************************
  251. C
  252.   350 WRITE(NOUT,360)
  253.   360 FORMAT(1X,13HRIM MENU MODE)
  254.   400 CONTINUE
  255.       INTOPT = 0
  256.   410 CONTINUE
  257.       CALL INTCON(INTOPT)
  258.       IF(INTOPT.EQ.K4EXIT) GO TO 900
  259.       IF(INTOPT.EQ.K4QUIT) GO TO 850
  260.       IF(INTOPT.EQ.K4COM) GO TO 600
  261.       IF(INTOPT.EQ.K4QUE) GO TO 600
  262.       IF(INTOPT.EQ.K4LOD) GO TO 800
  263.       IF((INTOPT.NE.K4CRE).AND.(INTOPT.NE.K4UPD)) GO TO 400
  264. C
  265. C  SET THE INPUT FILE TO SCHEMA AND READ THE FIRST RECORD
  266. C
  267.       CALL SETIN(K8SCH)
  268.       LENREC = 0
  269.       CALL LXLREC(DUM,LENREC,DUM)
  270. C
  271. C  COMPILE THE SCHEMA AND SET INPUT BACK TO "INPUT"
  272. C
  273.       CALL CSC
  274.       CALL SETIN(K8IN)
  275.       GO TO 410
  276. C
  277. C  ****************************************************************
  278. C
  279. C                  D I R E C T      S E C T I O N
  280. C
  281. C  ****************************************************************
  282. C
  283.   500 CONTINUE
  284.       IF(NEXTOP.EQ.K8BEGI) GO TO 600
  285.       IF(NEXTOP.EQ.K8RIM  ) GO TO 600
  286.       IF(NEXTOP.EQ.K8DEFI) GO TO 700
  287.       IF(NEXTOP.EQ.K8LOAD) GO TO 800
  288.       IF(NEXTOP.EQ.K8MENU) GO TO 350
  289. C
  290. C  BRANCH TO STATEMENT 400 IF RIM WAS CALLED FROM THE
  291. C  MENU MODE
  292. C
  293.       IF(INTOPT.EQ.K4QUE) GO TO 400
  294.       IF(NEXTOP.EQ.K8EXIT  ) GO TO 900
  295. C
  296. C  CALL RIM FOR QUERY FUNCTIONS
  297. C
  298.   600 CONTINUE
  299.       CALL RIM
  300.       GO TO 500
  301. C
  302. C  CALL CSC TO DEFINE THE SCHEMA
  303. C
  304.   700 CONTINUE
  305.       CALL CSC
  306.       NEXTOP = K8RIM
  307.       GO TO 500
  308. C
  309. C  CALL DBLOAD TO LOAD THE DATABASE
  310. C
  311.   800 CONTINUE
  312.       CALL DBLOAD
  313.       NEXTOP = K8RIM
  314.       IF(INTOPT.EQ.K4LOD) GO TO 410
  315.       GO TO 500
  316. C
  317. C  ****************************************************************
  318. C
  319. C                       E X I T     S E C T I O N
  320. C
  321. C  ****************************************************************
  322. C
  323. C  DROP THE DATABASE FILES - QUIT
  324. C
  325.   850 CONTINUE
  326.       GO TO 9999
  327.   900 CONTINUE
  328.       IF(BATCH) GO TO 999
  329.       IF(.NOT.CONNI) GO TO 999
  330.       IF(.NOT.CONNO) CALL SETOUT(K8OUT)
  331.       CALL RMDBPT(NAMDB,DBSTAT)
  332. C
  333. C  PRINT THE CLOSING MESSAGE AND EXIT
  334. C
  335.   999 CONTINUE
  336.       CALL RMDATE(IDAY)
  337.       CALL RMTIME(ITIME)
  338.       WRITE(NOUT,7001) IDAY,ITIME
  339.  7001 FORMAT(1X,17HEND RIM EXECUTION,25X,A8,4X,A8,/,/)
  340. C
  341. C  ERROR MESSAGES -------------------------------------------------
  342. C
  343.  8001 FORMAT(1X,41H-ERROR- EITHER "1" OR "2" MUST BE ENTERED,/)
  344. C
  345.  9999 CONTINUE
  346.       STOP
  347.       END
  348.         SUBROUTINE RIM
  349.         Include TEXT.BLK
  350. C
  351.         Include RMATTS.BLK
  352.         Include RMKEYW.BLK
  353.         Include CONST4.BLK
  354.         Include CONST8.BLK
  355.         Include FLAGS.BLK
  356.         Include RIMCOM.BLK
  357.         Include FILES.BLK
  358.         Include MISC.BLK
  359.         Include SELCOM.BLK
  360. C
  361.       LOGICAL EQKEYW
  362.       INTEGER IDT(2)
  363.       INTEGER DBSTAT
  364.         Include DCLAR4.BLK
  365. C
  366. C  ACCEPT USER INPUT
  367. C
  368.       NEXTOP = K8READ
  369.  1000 CONTINUE
  370.       IF(NEXTOP.NE.K8READ) GO TO 1100
  371.       CALL LODREC
  372.  1100 CONTINUE
  373.       NEXTOP = K8READ
  374. C
  375. C  CHECK COMMAND ON CARD
  376. C
  377.       IF(.NOT.EQKEYW(1,KWLIST,7)) GO TO 1300
  378. C                                   LISTREL
  379.       IF(.NOT.DFLAG) GO TO 1550
  380.       CALL LSTREL
  381.       GO TO 1000
  382.  1300 CONTINUE
  383.       IF(.NOT.EQKEYW(1,KWSELE,6)) GO TO 1305
  384. C                                   SELECT
  385.       IF(.NOT.DFLAG) GO TO 1550
  386.       CALL QUERY
  387.       GO TO 1000
  388.  1305 CONTINUE
  389.       IF(.NOT.EQKEYW(1,KWCHAN,6)) GO TO 1310
  390. C                                   CHANGE
  391.       IF(.NOT.DFLAG) GO TO 1550
  392.       CALL MODIFY
  393.       GO TO 1000
  394.  1310 CONTINUE
  395.       IF(.NOT.EQKEYW(1,KWCOMP,7)) GO TO 1315
  396. C                                   COMPUTE
  397.       IF(.NOT.DFLAG) GO TO 1550
  398.       CALL QUERY
  399.       GO TO 1000
  400.  1315 CONTINUE
  401.       IF(.NOT.EQKEYW(1,KWTALL,5)) GO TO 1320
  402. C                                   TALLY
  403.       IF(.NOT.DFLAG) GO TO 1550
  404.       CALL QUERY
  405.       GO TO 1000
  406.  1320 CONTINUE
  407.       IF(.NOT.EQKEYW(1,KWEXIT,4)) GO TO 1325
  408. C                                   EXIT
  409.       GO TO 3000
  410.  1325 CONTINUE
  411.       IF(.NOT.EQKEYW(1,KWLOAD,4)) GO TO 1330
  412. C                                   LOAD
  413.       IF(.NOT.DFLAG) GO TO 1550
  414.       NEXTOP = K8LOAD
  415.       GO TO 5000
  416.  1330 CONTINUE
  417.       IF(.NOT.EQKEYW(1,KWOPEN,4)) GO TO 1335
  418. C                                   OPEN
  419.       IF(LXITEM(DBSTAT).LT.2) GO TO 1495
  420.       IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.6)) GO TO 1334
  421.       WRITE (NOUT,1332)
  422.  1332 FORMAT(/39H -ERROR- THE DATABASE NAME MUST BE 1-6 ,
  423.      X       23HALPHANUMERIC CHARACTERS,/)
  424.       GO TO 1000
  425.  1334 CONTINUE
  426.       CALL RMCLOS
  427.       DBNAME = BLANK
  428.       CALL LXSREC(2,1,8,DBNAME,1)
  429.       CALL RMDBGT(DBNAME,DBSTAT)
  430.       IF(DBSTAT.NE.0) GO TO 1000
  431.       CALL RMOPEN(DBNAME)
  432.       IF(RMSTAT.NE.0) CALL WARN(RMSTAT,DBNAME,0)
  433.       GO TO 1000
  434.  1335 CONTINUE
  435.       IF(.NOT.EQKEYW(1,KWEXHI,7)) GO TO 1345
  436. C                                   EXHIBIT
  437.       IF(.NOT.DFLAG) GO TO 1550
  438.       CALL XHIBIT
  439.       GO TO 1000
  440.  1345 CONTINUE
  441.       IF(.NOT.EQKEYW(1,KWDEFI,6)) GO TO 1350
  442. C                                   DEFINE
  443.       GO TO 2000
  444.  1350 CONTINUE
  445.       IF(.NOT.EQKEYW(1,KWECHO,4)) GO TO 1355
  446. C                                   ECHO
  447.       CALL LXSET(KWECHO,K4ON)
  448.       ECHO = .TRUE.
  449.       GO TO 1000
  450.  1355 CONTINUE
  451.       IF(.NOT.EQKEYW(1,KWNOEC,6)) GO TO 1360
  452. C                                   NOECHO
  453.       CALL LXSET(KWECHO,K4OFF)
  454.       ECHO = .FALSE.
  455.       GO TO 1000
  456.  1360 CONTINUE
  457.       IF(.NOT.EQKEYW(1,KWNEWP,7)) GO TO 1365
  458. C                                   NEWPAGE
  459.       WRITE (NOUTR,1367)
  460.  1367 FORMAT(1H1)
  461.       GO TO 1000
  462.  1365 CONTINUE
  463.       IF(.NOT.EQKEYW(1,KWUSER,4)) GO TO 1370
  464. C                                   USER
  465.       IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.8)) GO TO 1369
  466.       WRITE(NOUT,1368)
  467.  1368 FORMAT(44H -ERROR- PASSWORDS MUST BE 1-8 ALPHANUMERIC ,
  468.      X       10HCHARACTERS)
  469.       GO TO 1000
  470.  1369 CONTINUE
  471.       USERID = BLANK
  472.       CALL LXSREC(2,1,8,USERID,1)
  473.       GO TO 1000
  474.  1370 CONTINUE
  475.       IF(.NOT.EQKEYW(1,KWRENA,6)) GO TO 1375
  476. C                                   RENAME
  477.       IF(.NOT.DFLAG) GO TO 1550
  478.       CALL MODIFY
  479.       GO TO 1000
  480.  1375 CONTINUE
  481.       IF(.NOT.EQKEYW(1,KWDELE,6)) GO TO 1380
  482. C                                   DELETE
  483.       IF(.NOT.DFLAG) GO TO 1550
  484.       CALL MODIFY
  485.       GO TO 1000
  486.  1380 CONTINUE
  487.       IF(.NOT.EQKEYW(1,KWREMO,6)) GO TO 1385
  488. C                                   REMOVE
  489.       IF(.NOT.DFLAG) GO TO 1550
  490.       CALL MODIFY
  491.       GO TO 1000
  492.  1385 CONTINUE
  493.       IF(.NOT.EQKEYW(1,KWQUIT,4)) GO TO 1390
  494. C                                   QUIT
  495.       GO TO 3000
  496.  1390 CONTINUE
  497.       IF(.NOT.EQKEYW(1,KWCLOS,5)) GO TO 1395
  498. C                                   CLOSE
  499.       IF(.NOT.DFLAG) GO TO 1550
  500.       CALL RMCLOS
  501.       GO TO 1000
  502.  1395 CONTINUE
  503.       IF(.NOT.EQKEYW(1,KWPRIN,5)) GO TO 1400
  504. C                                   PRINT
  505.       IF(.NOT.DFLAG) GO TO 1550
  506.       CALL RULES
  507.       GO TO 1000
  508.  1400 CONTINUE
  509.       IF(.NOT.EQKEYW(1,KWINTS,9)) GO TO 1405
  510. C                                   INTERSECT
  511.       IF(.NOT.DFLAG) GO TO 1550
  512.       CALL ISREL
  513.       GO TO 1000
  514.  1405 CONTINUE
  515.       IF(.NOT.EQKEYW(1,KWPROJ,7)) GO TO 1410
  516. C                                   PROJECT
  517.       IF(.NOT.DFLAG) GO TO 1550
  518.       CALL PJECT
  519.       GO TO 1000
  520.  1410 CONTINUE
  521.       IF(.NOT.EQKEYW(1,KWSUBT,8)) GO TO 1415
  522. C                                   SUBTRACT
  523.       IF(.NOT.DFLAG) GO TO 1550
  524.       CALL SUBREL
  525.       GO TO 1000
  526.  1415 CONTINUE
  527.       IF(.NOT.EQKEYW(1,KWJOIN,4)) GO TO 1420
  528. C                                   JOIN
  529.       IF(.NOT.DFLAG) GO TO 1550
  530.       CALL JOIREL
  531.       GO TO 1000
  532.  1420 CONTINUE
  533.       IF(.NOT.EQKEYW(1,KWBUIL,5)) GO TO 1430
  534. C                                   BUILD
  535.       IF(.NOT.DFLAG) GO TO 1550
  536.       CALL BUILD
  537.       GO TO 1000
  538.  1430 CONTINUE
  539.       IF(.NOT.EQKEYW(1,KWRELO,6)) GO TO 1435
  540. C                                   RELOAD
  541.       IF(.NOT.DFLAG) GO TO 1550
  542.       CALL RELOAD
  543.       GO TO 1000
  544.  1435 CONTINUE
  545.       IF(.NOT.EQKEYW(1,KWINPU,5)) GO TO 1440
  546. C                                   INPUT
  547.       GO TO 1600
  548.  1440 CONTINUE
  549.       IF(.NOT.EQKEYW(1,KWOUTP,6)) GO TO 1445
  550. C                                   OUTPUT
  551.       GO TO 1700
  552.  1445 CONTINUE
  553.       IF(.NOT.EQKEYW(1,KWTITL,5)) GO TO 1450
  554. C                                   TITLE
  555.       GO TO 2100
  556.  1450 CONTINUE
  557.       IF(.NOT.EQKEYW(1,KWDATE,4)) GO TO 1455
  558. C                                   DATE
  559.       GO TO 2200
  560.  1455 CONTINUE
  561.       IF(.NOT.EQKEYW(1,KWBLAN,5)) GO TO 1460
  562. C                                   BLANK
  563.       GO TO 2300
  564.  1460 CONTINUE
  565.       IF(.NOT.EQKEYW(1,KWUNLO,6)) GO TO 1465
  566. C                                   UNLOAD
  567.       IF(.NOT.DFLAG) GO TO 1550
  568.       CALL UNLOAD
  569.       GO TO 1000
  570.  1465 CONTINUE
  571.       IF(.NOT.EQKEYW(1,KWLINE,5)) GO TO 1470
  572. C                                   LINES
  573.       IF(LXID(2).NE.KZINT) GO TO 2301
  574.       ULPP = LXIREC(2)
  575.       IF(ULPP.GE.0) GO TO 1000
  576.       ULPP = 0
  577.       WRITE(NOUT,1466)
  578.  1466 FORMAT(50H -WARNING- LINES ENTERED IS OUT OF RANGE, RESET TO,
  579.      X        8H DEFAULT,/)
  580.       GO TO 1000
  581.  1470 CONTINUE
  582.       IF(.NOT.EQKEYW(1,KWWIDT,5)) GO TO 1475
  583. C                                   WIDTH
  584.       IF(LXID(2).NE.KZINT) GO TO 2301
  585.       UMCPL = LXIREC(2)
  586.       IF(UMCPL.LT.0) UMCPL = 0
  587.       IF(((UMCPL.GE.20).AND.(UMCPL.LE.132)).OR.(UMCPL.EQ.0)) GO TO 1000
  588. C
  589. C  ILLEGAL WIDTH SPECIFICATION
  590. C
  591.       IF(UMCPL.GT.132) UMCPL = 132
  592.       IF(UMCPL.LT.20)  UMCPL = 20
  593.       WRITE(NOUT,1472) UMCPL
  594.  1472 FORMAT(51H -WARNING- WIDTH ENTERED IS OUT OF RANGE, RESET TO ,
  595.      X    I4,/)
  596.       GO TO 1000
  597.  1475 CONTINUE
  598. C                                     MENU
  599.       IF(.NOT.EQKEYW(1,KWMENU,4)) GO TO 1480
  600.       NEXTOP = K8MENU
  601.       IF(.NOT.BATCH) GO TO 3500
  602.       WRITE(NOUT,1476)
  603.  1476 FORMAT(39H -ERROR- MENU MODE NOT ALLOWED IN BATCH )
  604.       NEXTOP = K8READ
  605.       GO TO 1000
  606.  1480 CONTINUE
  607. C                                    TOLERANCE
  608.       IF(.NOT.EQKEYW(1,KWTOLE,9)) GO TO 1485
  609.       IF(LXID(2).NE.KZREAL) GO TO 1495
  610.       TOL = RXREC(2)
  611.       PCENT = .FALSE.
  612.       IF(.NOT.EQKEYW(3,KWPERC,7)) GO TO 1000
  613.       TOL = TOL/100.
  614.       PCENT = .TRUE.
  615.       GO TO 1000
  616.  1485 CONTINUE
  617. C                                    CHECK
  618.       IF(.NOT.EQKEYW(1,KWCHEC,5)) GO TO 1490
  619.       RUCK = .TRUE.
  620.       GO TO 1000
  621.  1490 CONTINUE
  622. C                                    NOCHECK
  623.       IF(.NOT.EQKEYW(1,KWNOCH,7)) GO TO 1495
  624.       RUCK = .FALSE.
  625.       GO TO 1000
  626.  1495 CONTINUE
  627. C
  628. C     NOT IDENTIFIABLE COMMAND
  629. C
  630.       WRITE (NOUT,1499)
  631.  1499 FORMAT(37H -ERROR- INVALID COMMAND - RETYPE IT  )
  632.  1500 CONTINUE
  633.       GO TO 1000
  634.  1550 CONTINUE
  635. C
  636. C     NO RELATIONS YET
  637. C
  638.       WRITE (NOUT,1560)
  639.  1560 FORMAT(53H -ERROR- NO RELATIONS DEFINED YET FOR THIS DATA BASE ,/)
  640.       GO TO 1000
  641. C
  642. C     PROCESS THE INPUT COMMAND
  643. C
  644.  1600 CONTINUE
  645.       IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.7)) GO TO 1610
  646.       WRITE(NOUT,1800)
  647.       GO TO 1000
  648.  1610 CONTINUE
  649.       IFILE = BLANK
  650.       CALL LXSREC(2,1,LXLENC(2),IFILE,1)
  651.       CALL SETIN(IFILE)
  652.       GO TO 1000
  653. C
  654. C     PROCESS THE OUTPUT COMMAND
  655. C
  656.  1700 CONTINUE
  657.       IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.7)) GO TO 1710
  658.       WRITE(NOUT,1800)
  659.       GO TO 1000
  660.  1710 CONTINUE
  661.       IFILE = BLANK
  662.       CALL LXSREC(2,1,LXLENC(2),IFILE,1)
  663.       CALL SETOUT(IFILE)
  664.       GO TO 1000
  665.  1800 FORMAT(45H -ERROR- FILE NAMES MUST BE 1-7 ALPHANUMERIC ,
  666.      X       10HCHARACTERS)
  667. C
  668. C  GO TO THE DEFINE MODULE.
  669. C
  670.  2000 CONTINUE
  671.       NEXTOP = K8DEFI
  672.       GO TO 3500
  673. C
  674. C  PROCESS THE TITLE COMMAND
  675. C
  676.  2100 CONTINUE
  677.       KOL = 78
  678.       IF(.NOT.CONNO) KOL = 132
  679.       IF(UMCPL.NE.0) KOL = UMCPL
  680.       KOLW = ((KOL-1)/CHPWD + 1)*CHPWD
  681.       CALL FILCH(LINE,1,KOLW,BLANK)
  682.       KCHAR = LXLENC(2)
  683.       IF(KCHAR.LE.KOL) GOTO 2150
  684.       KCHAR = KOL-2
  685.       WRITE(NOUT,100)
  686.  100  FORMAT(53H -WARNING- TITLE ENTERED WAS TOO LONG AND WILL BE TRU,
  687.      X 6HNCATED )
  688. C
  689.  2150 CONTINUE
  690.       KSTRT = (KOL-KCHAR)/2 + 1
  691.       CALL LXSREC(2,1,KCHAR,LINE,KSTRT)
  692.       CALL SPOUT(LINE,KOL)
  693.       GO TO 1000
  694. C
  695. C  PROCESS THE DATE COMMAND
  696. C
  697.  2200 CONTINUE
  698.       KOL = 78
  699.       IF(.NOT.CONNO) KOL = 132
  700.       IF(UMCPL.NE.0) KOL = UMCPL
  701.       KOLW = ((KOL-1)/CHPWD + 1)*CHPWD
  702.       CALL FILCH(LINE,1,KOLW,BLANK)
  703.       KSTRT = KOL/2 - 4
  704.       CALL RMDATE(IDT)
  705.       CALL STRMOV(IDT,1,8,LINE,KSTRT)
  706.       CALL SPOUT(LINE,KOL)
  707.       GO TO 1000
  708. C
  709. C  PROCESS THE BLANK COMMAND
  710. C
  711.  2300 CONTINUE
  712.       IF(LXITEM(ITEM).EQ.1) GO TO 2303
  713.       IF(LXID(2).EQ.KZINT) GO TO 2303
  714.  2301 CONTINUE
  715.       WRITE(NOUT,2302)
  716.  2302 FORMAT(34H -ERROR- ITEM 2 MUST BE AN INTEGER)
  717.       GO TO 1000
  718.  2303 CONTINUE
  719.       KOL = 1
  720.       IF(LXITEM(ITEM).EQ.2) KOL = LXIREC(2)
  721.       IF(KOL.LE.0) KOL = 1
  722.       DO 2310 K=1,KOL
  723.       WRITE (NOUTR,2305)
  724.  2305 FORMAT(1H )
  725.  2310 CONTINUE
  726.       GO TO 1000
  727. C
  728. C  CLOSE THE DATA BASE AND EXIT.
  729. C
  730.  3000 CONTINUE
  731.       NEXTOP = K8EXIT
  732.  3500 CONTINUE
  733.       CALL RMCLOS
  734.  5000 CONTINUE
  735.       RETURN
  736.       END
  737.       SUBROUTINE ADDDAT(INDEX,ID,ARRAY,LENGTH)
  738.         Include TEXT.BLK
  739. C
  740. C  PURPOSE:   ADD A TUPLE TO THE DATA FILE
  741. C
  742. C  PARAMETERS:
  743. C         INDEX---BLOCK REFERENCE NUMBER
  744. C         ID------PACKED ID WORD WITH OFFSET,IOBN
  745. C         ARRAY---ARRAY TO RECEIVE THE TUPLE
  746. C         LENGTH--LENGTH OF THE TUPLE
  747.         Include F2COM.BLK
  748.         Include RIMCOM.BLK
  749.         Include BUFFER.BLK
  750.         Include FLAGS.BLK
  751. C
  752.       INTEGER OFFSET
  753.       INTEGER ARRAY(1)
  754. C
  755. C  UNPACK THE ID WORD.
  756. C
  757.       CALL ITOH(OFFSET,IOBN,ID)
  758. C
  759. C  CALCULATE THE NEW ID VALUE.
  760. C
  761.       IF(LF2WRD + LENGTH + 1 .LE. LENBF2) GO TO 100
  762.       LF2REC = LF2REC + 1
  763.       LF2WRD = 1
  764.   100 CONTINUE
  765.       CALL HTOI(LF2WRD,LF2REC,ID)
  766.       IF(IOBN.EQ.0) GO TO 500
  767. C
  768. C  SEE IF THE NEEDED BLOCK IS CURRENTLY IN CORE.
  769. C
  770.       NUMBLK = 0
  771.       DO 200 I=1,3
  772.       IF(IOBN.EQ.CURBLK(I)) NUMBLK = I
  773.   200 CONTINUE
  774.       IF(NUMBLK.NE.0) GO TO 400
  775.       NUMBLK = INDEX
  776. C
  777. C  WE MUST DO PAGING.
  778. C
  779. C  SEE IF THE CURRENT BLOCK NEEDS WRITING.
  780. C
  781.       IF(MODFLG(NUMBLK).EQ.0) GO TO 300
  782. C
  783. C  WRITE OUT THE CURRENT BLOCK.
  784. C
  785.       KQ1 = BLKLOC(NUMBLK)
  786.       CALL RIOOUT(FILE2,CURBLK(NUMBLK),BUFFER(KQ1),LENBF2,IOS)
  787.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  788.   300 CONTINUE
  789. C
  790. C  READ IN THE NEEDED BLOCK.
  791. C
  792.       CALL BLKCHG(NUMBLK,LENBF2,1)
  793.       KQ1 = BLKLOC(NUMBLK)
  794.       CALL RIOIN(FILE2,IOBN,BUFFER(KQ1),LENBF2,IOS)
  795.       CURBLK(NUMBLK) = IOBN
  796.       IF(IOS.EQ.0) GO TO 400
  797. C
  798. C  WRITE OUT THE RECORD FOR THE FIRST TIME.
  799. C
  800.       CALL RIOOUT(FILE2,IOBN,BUFFER(KQ1),LENBF2,IOS)
  801.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  802.   400 CONTINUE
  803.       MODFLG(NUMBLK) = 1
  804.       IFMOD = .TRUE.
  805. C
  806. C  FIX UP THE ID POINTER SO IT POINTS TO THE NEXT TUPLE.
  807. C
  808.       KQ0 = BLKLOC(NUMBLK) - 1
  809.       ISIGN = 1
  810.       IF(BUFFER(KQ0 + OFFSET).LT.0) ISIGN = -1
  811.       BUFFER(KQ0 + OFFSET) = ISIGN * ID
  812.       MODFLG(NUMBLK) = 1
  813.       IFMOD = .TRUE.
  814. C
  815. C  NOW MOVE THE NEW TUPLE.
  816. C
  817.   500 CONTINUE
  818.       CALL ITOH(OFFSET,IOBN,ID)
  819. C
  820. C  SEE IF THE NEEDED BLOCK IS CURRENTLY IN CORE.
  821. C
  822.       NUMBLK = 0
  823.       DO 600 I=1,3
  824.       IF(IOBN.EQ.CURBLK(I)) NUMBLK = I
  825.   600 CONTINUE
  826.       IF(NUMBLK.NE.0) GO TO 800
  827.       NUMBLK = INDEX
  828. C
  829. C  WE MUST DO PAGING.
  830. C
  831. C  SEE IF THE CURRENT BLOCK NEEDS WRITING.
  832. C
  833.       IF(MODFLG(NUMBLK).EQ.0) GO TO 700
  834. C
  835. C  WRITE OUT THE CURRENT BLOCK.
  836. C
  837.       KQ1 = BLKLOC(NUMBLK)
  838.       CALL RIOOUT(FILE2,CURBLK(NUMBLK),BUFFER(KQ1),LENBF2,IOS)
  839.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  840.   700 CONTINUE
  841. C
  842. C  READ IN THE NEEDED BLOCK.
  843. C
  844.       CALL BLKCHG(NUMBLK,LENBF2,1)
  845.       KQ1 = BLKLOC(NUMBLK)
  846.       CURBLK(NUMBLK) = IOBN
  847.       IF(LF2WRD.EQ.1) GO TO 750
  848.       CALL RIOIN(FILE2,IOBN,BUFFER(KQ1),LENBF2,IOS)
  849.       IF(IOS.EQ.0) GO TO 800
  850. C
  851. C  WRITE OUT THE RECORD FOR THE FIRST TIME.
  852. C
  853.   750 CONTINUE
  854.       CALL RIOOUT(FILE2,IOBN,BUFFER(KQ1),LENBF2,IOS)
  855.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  856.   800 CONTINUE
  857.       MODFLG(NUMBLK) = 1
  858.       IFMOD = .TRUE.
  859. C
  860. C  MOVE THE TUPLE TO THE PAGE.
  861. C
  862.       KQ0 = BLKLOC(NUMBLK) - 1
  863.       BUFFER(KQ0 + OFFSET) = 0
  864.       BUFFER(KQ0 + OFFSET + 1) = LENGTH
  865.       CALL BLKMOV(BUFFER(KQ0 + OFFSET + 2),ARRAY(1),LENGTH)
  866.       LF2WRD = LF2WRD + LENGTH + 2
  867. C
  868. C  ALL DONE.
  869. C
  870.       RETURN
  871.       END
  872.       SUBROUTINE ATTADD
  873.         Include TEXT.BLK
  874. C
  875. C  PURPOSE:   ADD A NEW TUPLE TO THE ATTRIBUTE RELATION
  876. C
  877.         Include TUPLEA.BLK
  878.         Include ATTBLE.BLK
  879.         Include F1COM.BLK
  880.         Include FLAGS.BLK
  881. C
  882. C  GET THE PAGE FOR ADDING NEW TUPLES.
  883. C
  884.       MRSTRT = NAROW
  885.       CALL ATTPAG(MRSTRT)
  886.       I = MRSTRT
  887.       NAROW = NAROW + 1
  888.       IF(I.EQ.APBUF) NAROW = (APBUF * LF1REC) + 1
  889. C
  890. C  MOVE THE DATA FROM THE TUPLE TO THE BUFFER.
  891. C
  892.       ATTBLE(1,I) = NAROW
  893.       CALL BLKMOV(ATTBLE(2,I),ATTNAM,2)
  894.       CALL BLKMOV(ATTBLE(4,I),RELNAM,2)
  895.       ATTBLE(6,I) = ATTCOL
  896.       ATTBLE(7,I) = ATTLEN
  897.       ATTBLE(8,I) = ATTYPE
  898.       ATTBLE(9,I) = ATTKEY
  899.       ATTMOD = 1
  900.       IFMOD = .TRUE.
  901.       CROW = 0
  902.       LROW = 0
  903.       IF(I.LT.APBUF) RETURN
  904. C
  905. C  WE JUST FILLED A BUFFER. MAKE SURE ATTBLE GETS THE NEXT ONE.
  906. C
  907.       ATTBUF(1) = NAROW
  908.       MRSTRT = NAROW
  909.       CALL ATTPAG(MRSTRT)
  910.       RETURN
  911.       END
  912.       SUBROUTINE ATTDEL(STATUS)
  913.         Include TEXT.BLK
  914. C
  915. C  PURPOSE:   DELETE THE CURRENT TUPLE FROM THE ATTRIBUTE RELATION
  916. C             BASED ON CONDITIONS SET UP IN LOCATT AND ATTGET
  917. C
  918. C  PARAMETERS:
  919. C         STATUS--STATUS VARIABLE - 0 MEANS OK, 1 MEANS NO WAY
  920.         Include RMATTS.BLK
  921.         Include ATTBLE.BLK
  922.         Include START.BLK
  923.       INTEGER STATUS
  924. C
  925.       STATUS = 0
  926.       IF(LROW.EQ.0) GO TO 9000
  927. C
  928. C  CHANGE THE TUPLE STATUS FLAG TO DELETED.
  929. C
  930.       ATTBLE(1,LROW) = -ATTBLE(1,LROW)
  931.       ATTMOD = 1
  932.       GO TO 9999
  933. C
  934. C  UNABLE TO FIND WHAT WE ARE LOOKING FOR.
  935. C
  936.  9000 CONTINUE
  937.       STATUS = 1
  938.  9999 CONTINUE
  939.       RETURN
  940.       END
  941.       SUBROUTINE ATTGET(STATUS)
  942.         Include TEXT.BLK
  943. C
  944. C  PURPOSE:   RETRIEVE THE NEXT TUPLE FROM THE ATTRIBUTE RELATION
  945. C             BASED ON CONDITIONS SET UP IN LOCATT
  946. C
  947. C  PARAMETERS:
  948. C         STATUS--STATUS VARIABLE - 0 MEANS OK, 1 MEANS NO WAY
  949.         Include TUPLEA.BLK
  950.         Include ATTBLE.BLK
  951.         Include MISC.BLK
  952.       INTEGER STATUS
  953.       LOGICAL EQ
  954.       LOGICAL NE
  955. C
  956.       STATUS = 0
  957.       IF(CROW.EQ.0) GO TO 9000
  958. C
  959. C  SEE WHAT THE CALLER WANTS.
  960. C
  961.       IF(EQ(CRNAME,BLANK)) GO TO 1000
  962. C
  963. C  CRNAME IS SPECIFIED.
  964. C
  965.       I = CROW
  966.       GO TO 200
  967.   100 CONTINUE
  968.       CALL ATTPAG(MRSTRT)
  969. C
  970. C  LOOK FOR THE ATTRIBUTE IN THIS RELATION.
  971. C
  972.       I = MRSTRT
  973.   200 CONTINUE
  974.       IF(I.GT.APBUF) GO TO 300
  975.       IF(NE(ATTBLE(4,I),CRNAME)) GO TO 9000
  976.       IF(EQ(CANAME,BLANK)) GO TO 2000
  977.       IF(EQ(ATTBLE(2,I),CANAME)) GO TO 2000
  978.       I = I + 1
  979.       GO TO 200
  980. C
  981. C  GET THE NEXT PAGE.
  982. C
  983.   300 CONTINUE
  984.       MRSTRT = ATTBUF(1)
  985.       IF(MRSTRT.EQ.0) GO TO 9000
  986.       GO TO 100
  987. C
  988. C  SCAN FOR ATTRIBUTE WITHOUT RELATION SPECIFIED.
  989. C
  990.  1000 CONTINUE
  991.       I = CROW
  992.       GO TO 1200
  993.  1100 CONTINUE
  994.       CALL ATTPAG(MRSTRT)
  995.       I = MRSTRT
  996.  1200 CONTINUE
  997.       IF(I.GT.APBUF) GO TO 1400
  998.       IF(ATTBLE(1,I).LT.0) GO TO 1300
  999.       IF(EQ(ATTBLE(2,I),CANAME)) GO TO 2000
  1000.  1300 CONTINUE
  1001.       I = I + 1
  1002.       GO TO 1200
  1003. C
  1004. C  GET THE NEXT PAGE.
  1005. C
  1006.  1400 CONTINUE
  1007.       MRSTRT = ATTBUF(1)
  1008.       IF(MRSTRT.EQ.0) GO TO 9000
  1009.       GO TO 1100
  1010. C
  1011. C  MOVE THE STUFF FROM ROW CROW.
  1012. C
  1013.  2000 CONTINUE
  1014.       CROW = I
  1015.       CALL BLKMOV(ATTNAM,ATTBLE(2,CROW),2)
  1016.       CALL BLKMOV(RELNAM,ATTBLE(4,CROW),2)
  1017.       ATTCOL = ATTBLE(6,CROW)
  1018.       ATTLEN = ATTBLE(7,CROW)
  1019.       ATTYPE = ATTBLE(8,CROW)
  1020.       ATTKEY = ATTBLE(9,CROW)
  1021. C
  1022. C  UNPAC THE LENGTH DATA
  1023. C
  1024.       CALL ITOH(ATTCHA,ATTWDS,ATTLEN)
  1025.       LROW = CROW
  1026.       CROW = CROW + 1
  1027.       GO TO 9999
  1028. C
  1029. C  UNABLE TO FIND WHAT WE ARE LOOKING FOR.
  1030. C
  1031.  9000 CONTINUE
  1032.       STATUS = 1
  1033.       CROW = 0
  1034.       LROW = 0
  1035.  9999 CONTINUE
  1036.       RETURN
  1037.       END
  1038.       SUBROUTINE ATTNEW(RNAME,NATT)
  1039.         Include TEXT.BLK
  1040. C
  1041. C  PURPOSE:   ADD A NEW RELATION TO THE ATTRIBUTE RELATION
  1042. C
  1043. C  PARAMETERS:
  1044. C         RNAME---NAME OF A RELATION
  1045. C         NATT----NUMBER OF ATTRIBUTES IN THE RELATION
  1046.         Include RMATTS.BLK
  1047.         Include ATTBLE.BLK
  1048.         Include F1COM.BLK
  1049.         Include START.BLK
  1050.         Include DCLAR1.BLK
  1051. C
  1052. C  ADJUST NAROW IF ALL ATTRIBUTES WILL NOT FIT ON THE PAGE.
  1053. C
  1054.       MRSTRT = NAROW
  1055.       CALL ATTPAG(MRSTRT)
  1056.       I = MRSTRT
  1057.       IF((I + NATT).LE.APBUF) GO TO 100
  1058.       NAROW = (APBUF * LF1REC) + 1
  1059.       ATTBUF(1) = NAROW
  1060.       ATTMOD = 1
  1061.   100 CONTINUE
  1062.       IF(START.NE.KSFRIA) KSFRIA = START
  1063.       RETURN
  1064.       END
  1065.       SUBROUTINE ATTPAG(THEROW)
  1066.         Include TEXT.BLK
  1067. C
  1068. C  PURPOSE:   DO PAGING AS NEEDED FOR THE ATTRIBUTE RELATION
  1069. C
  1070. C  PARAMETERS:
  1071. C         THEROW--INPUT - ROW WANTED
  1072. C                 OUTPUT - ACTUAL ROW TO USE IN THE BUFFER
  1073.         Include ATTBLE.BLK
  1074.         Include RIMCOM.BLK
  1075.         Include F1COM.BLK
  1076.       INTEGER THEROW
  1077. C
  1078. C  TURN THE REQUESTED ROW INTO A RECORD AND OFFSET.
  1079. C
  1080.       NNREC = ((THEROW - 1) / APBUF) + 1
  1081.       NNROW = THEROW - ((NNREC - 1) * APBUF)
  1082. C
  1083. C  SEE IF WE ALREADY HAVE THIS RECORD IN THE BUFFER.
  1084. C
  1085.       IF(NNREC.EQ.CAREC) GO TO 300
  1086. C
  1087. C  WE MUST DO PAGING.
  1088. C
  1089. C  SEE IF THE CURRENT RECORD IN THE BUFFER HAS BEEN MODIFIED.
  1090. C
  1091.       IF(ATTMOD.EQ.0) GO TO 100
  1092. C
  1093. C  WRITE OUT THE CURRENT RECORD.
  1094. C
  1095.       CALL RIOOUT(FILE1,CAREC,ATTBUF,LENBF1,IOS)
  1096.       IF(IOS.NE.0) RMSTAT = 2100 + IOS
  1097. C
  1098. C  READ IN THE NEEDED RECORD.
  1099. C
  1100.   100 CONTINUE
  1101.       ATTMOD = 0
  1102.       IF(NNREC.GT.LF1REC) GO TO 150
  1103.       CALL RIOIN(FILE1,NNREC,ATTBUF,LENBF1,IOS)
  1104.       IF(IOS.EQ.0) GO TO 200
  1105. C
  1106. C  THERE WAS NO DATA ON THE FILE - WRITE SOME.
  1107. C
  1108.   150 CONTINUE
  1109.       CALL ZEROIT(ATTBUF,LENBF1)
  1110.       CALL RIOOUT(FILE1,NNREC,ATTBUF,LENBF1,IOS)
  1111.       IF(IOS.NE.0) RMSTAT = 2100 + IOS
  1112.       LF1REC = LF1REC + 1
  1113.   200 CONTINUE
  1114.       CAREC = NNREC
  1115. C
  1116. C  SET THE POINTER TO THE ACTUAL ROW IN THE BUFFER.
  1117. C
  1118.   300 CONTINUE
  1119.       THEROW = NNROW
  1120.       RETURN
  1121.       END
  1122.       SUBROUTINE ATTPUT(STATUS)
  1123.         Include TEXT.BLK
  1124. C
  1125. C  PURPOSE:   REPLACE THE CURRENT TUPLE FROM THE ATTRIBUTE RELATION
  1126. C             BASED ON CONDITIONS SET UP IN LOCATT AND ATTGET
  1127. C
  1128. C  PARAMETERS:
  1129. C         STATUS--STATUS VARIABLE - 0 MEANS OK, 1 MEANS NO WAY
  1130.         Include FLAGS.BLK
  1131.         Include TUPLEA.BLK
  1132.         Include ATTBLE.BLK
  1133.       INTEGER STATUS
  1134. C
  1135.       STATUS = 0
  1136.       IF(LROW.EQ.0) GO TO 9000
  1137. C
  1138. C  MOVE THE STUFF TO ROW LROW.
  1139. C
  1140.       CALL BLKMOV(ATTBLE(2,LROW),ATTNAM,2)
  1141.       CALL BLKMOV(ATTBLE(4,LROW),RELNAM,2)
  1142.       ATTBLE(6,LROW) = ATTCOL
  1143.       ATTBLE(7,LROW) = ATTLEN
  1144.       ATTBLE(8,LROW) = ATTYPE
  1145.       ATTBLE(9,LROW) = ATTKEY
  1146.       ATTMOD = 1
  1147.       IFMOD = .TRUE.
  1148.       GO TO 9999
  1149. C
  1150. C  UNABLE TO FIND WHAT WE ARE LOOKING FOR.
  1151. C
  1152.  9000 CONTINUE
  1153.       STATUS = 1
  1154.  9999 CONTINUE
  1155.       RETURN
  1156.       END
  1157.       SUBROUTINE BLKCHG(IND,NROWS,NCOLS)
  1158.         Include TEXT.BLK
  1159. C
  1160. C  PURPOSE:    CHANGE THE DIMENSIONS OF AN EXISTING BLOCK
  1161. C
  1162. C  PARAMETERS
  1163. C     INPUT:   IND-----BLOCK INDEX
  1164. C              NROWS---NUMBER OF ROWS
  1165. C              NCOLS---NUMBER OF COLUMNS
  1166.         Include INCORE.BLK
  1167.         Include RIMCOM.BLK
  1168.         Include BUFFER.BLK
  1169. C
  1170. C  SEE IF THE BLOCK HAS EXISTING DATA.
  1171. C
  1172.       IF(BLOCKS(1,IND).NE.0) GO TO 100
  1173. C
  1174. C  USE BLKDEF SINCE THIS IS A NEW BLOCK.
  1175. C
  1176.       CALL BLKDEF(IND,NCOLS,NROWS)
  1177.       RETURN
  1178. C
  1179. C  EXTRACT THE EXISTING DIMENSIONS.
  1180. C
  1181.   100 CONTINUE
  1182.       KNR = BLOCKS(2,IND)
  1183.       KNC = BLOCKS(3,IND)
  1184.       NWOLD = KNR * KNC
  1185.       KS = BLOCKS(1,IND)
  1186. C
  1187. C  SEE IF WE EXPAND OR CONTRACT.
  1188. C
  1189.       NWNEW = NROWS * NCOLS
  1190.       IF(NWNEW.EQ.NWOLD) RETURN
  1191.       NWADD = NWNEW - NWOLD
  1192.       IF(NEXT + NWADD .GT. LIMIT) GO TO 7500
  1193. C
  1194. C  MAKE ROOM IN THE BUFFER.
  1195. C
  1196.       MOVE = NEXT - (KS+NWOLD)
  1197.       IF(NWADD.GT.0) MOVE = -MOVE
  1198.       IF(KS + NWOLD .LT. NEXT)
  1199.      X CALL BLKMOV(BUFFER(KS+NWNEW),BUFFER(KS+NWOLD),MOVE)
  1200.       IF(NWADD.GT.0) CALL ZEROIT(BUFFER(KS+NWOLD),NWADD)
  1201. C
  1202. C  UPDATE THE INCORE INDEX.
  1203. C
  1204.       BLOCKS(1,IND) = KS
  1205.       BLOCKS(2,IND) = NROWS
  1206.       BLOCKS(3,IND) = NCOLS
  1207.       DO 200 I=1,NUMBL
  1208.       IF(BLOCKS(1,I).EQ.0) GO TO 200
  1209.       ITEST = BLOCKS(1,I)
  1210.       IF(ITEST.LE.KS) GO TO 200
  1211.       BLOCKS(1,I) = BLOCKS(1,I) + NWADD
  1212.   200 CONTINUE
  1213.       NEXT = NEXT + NWADD
  1214.       RETURN
  1215. C
  1216. C  NOT ENOUGH ROOM.
  1217. C
  1218.  7500 CONTINUE
  1219.       RMSTAT = 1001
  1220.       RETURN
  1221.       END
  1222.       SUBROUTINE BLKCLN
  1223.         Include TEXT.BLK
  1224. C
  1225. C  PURPOSE: CLEAN OUT THE ENTIRE BUFFER AREA
  1226. C
  1227. C  PARAMETERS -- NONE
  1228. C
  1229.         Include INCORE.BLK
  1230.         Include F2COM.BLK
  1231.         Include BUFFER.BLK
  1232.         Include RIMCOM.BLK
  1233. C
  1234. C  WRITE OUT ANY PAGES THAT HAVE BEEN MODIFIED
  1235. C
  1236.       DO 100 I=1,3
  1237.       IF(MODFLG(I).EQ.0) GO TO 90
  1238.       KQ1 = BLKLOC(I)
  1239.       CALL RIOOUT(FILE2,CURBLK(I),BUFFER(KQ1),LENBF2,IOS)
  1240.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  1241.       MODFLG(I) = 0
  1242.    90 CONTINUE
  1243.       CURBLK(I) = 0
  1244.   100 CONTINUE
  1245. C
  1246. C  ZERO OUT BLOCKS AND BUFFER
  1247. C
  1248.       CALL ZEROIT(BLOCKS(1,1),60)
  1249.       NEXT = 1
  1250.       NUMBL = 0
  1251.       CALL ZEROIT(BUFFER(1),LIMIT)
  1252.       RETURN
  1253.       END
  1254.       SUBROUTINE BLKCLR(IND)
  1255.         Include TEXT.BLK
  1256. C
  1257. C  PURPOSE:    CLEAR A BLOCK FROM THE INCORE BUFFER
  1258. C
  1259. C  PARAMETERS
  1260. C     INPUT:   IND-----BLOCK INDEX
  1261.         Include INCORE.BLK
  1262.         Include BUFFER.BLK
  1263. C
  1264. C  SEE IF ANYTHING IS THERE NOW.
  1265. C
  1266.       IF(BLOCKS(1,IND).EQ.0) RETURN
  1267.       KNR = BLOCKS(2,IND)
  1268.       KNC = BLOCKS(3,IND)
  1269.       NWOLD = KNR * KNC
  1270.       KS = BLOCKS(1,IND)
  1271. C
  1272. C  ZERO OUT THE SPACE.
  1273. C
  1274.       CALL ZEROIT(BUFFER(KS),NWOLD)
  1275. C
  1276. C  COMPRESS THE REMAINING BLOCKS.
  1277. C
  1278.       MOVE = NEXT - (KS+NWOLD)
  1279.       IF(KS+NWOLD.NE.NEXT)
  1280.      X CALL BLKMOV(BUFFER(KS),BUFFER(KS + NWOLD),MOVE)
  1281. C
  1282. C  UPDATE THE INCORE INDEX.
  1283. C
  1284.       BLOCKS(1,IND) = 0
  1285.       DO 100 I=1,NUMBL
  1286.       IF(BLOCKS(1,I).EQ.0) GO TO 100
  1287.       IF(BLOCKS(1,I).LE.KS) GO TO 100
  1288.       BLOCKS(1,I) = BLOCKS(1,I) - NWOLD
  1289.   100 CONTINUE
  1290.       NEXT = NEXT - NWOLD
  1291.       IF(IND.EQ.NUMBL) NUMBL = NUMBL - 1
  1292.       RETURN
  1293.       END
  1294.       SUBROUTINE BLKDEF(IND,NROWS,NCOLS)
  1295.         Include TEXT.BLK
  1296. C
  1297. C  PURPOSE:    DEFINE A NEW BLOCK FOR THE INCORE BUFFER
  1298. C
  1299. C  PARAMETERS
  1300. C     INPUT:   IND-----BLOCK INDEX
  1301. C              NROWS---NUMBER OF ROWS
  1302. C              NCOLS---NUMBER OF COLUMNS
  1303.         Include INCORE.BLK
  1304.         Include RIMCOM.BLK
  1305.         Include BUFFER.BLK
  1306. C
  1307. C  CLEAR ANY EXISTING BLOCK FOR THIS INDEX.
  1308. C
  1309.       IF(BLOCKS(1,IND).NE.0) CALL BLKCLR(IND)
  1310. C
  1311. C  SET UP THE NEW BLOCK.
  1312. C
  1313.       NWNEW = NROWS * NCOLS
  1314.       IF(NEXT + NWNEW .GT.LIMIT) GO TO 7500
  1315.       CALL ZEROIT(BUFFER(NEXT),NWNEW)
  1316. C
  1317. C  UPDATE THE INCORE INDEX.
  1318. C
  1319.       BLOCKS(1,IND) = NEXT
  1320.       BLOCKS(2,IND) = NROWS
  1321.       BLOCKS(3,IND) = NCOLS
  1322.       NEXT = NEXT + NWNEW
  1323.       IF(IND.GT.NUMBL) NUMBL = IND
  1324.       RETURN
  1325. C
  1326. C  NOT ENOUGH ROOM.
  1327. C
  1328.  7500 CONTINUE
  1329.       RMSTAT = 1001
  1330.       RETURN
  1331.       END
  1332.       SUBROUTINE BLKEXT(IND,NROWS,NCOLS)
  1333.         Include TEXT.BLK
  1334. C
  1335. C  PURPOSE:    EXTRACT THE NUMBER OF ROWS AND COLUMNS FOR A BLOCK
  1336. C
  1337. C  PARAMETERS
  1338. C     INPUT:   IND-----BLOCK INDEX
  1339. C     OUTPUT:  NROWS---NUMBER OF ROWS
  1340. C              NCOLS---NUMBER OF COLUMNS
  1341.         Include INCORE.BLK
  1342. C
  1343. C  EXTRACT THE DATA FROM BLOCKS.
  1344. C
  1345.       NROWS = BLOCKS(2,IND)
  1346.       NCOLS = BLOCKS(3,IND)
  1347.       RETURN
  1348.       END
  1349.       INTEGER FUNCTION BLKLOC(IND)
  1350.         Include TEXT.BLK
  1351. C
  1352. C  PURPOSE:    RETURN THE STARTING ADDRESS FOR THE REQUESTED BLOCK
  1353. C
  1354. C  PARAMETERS
  1355. C     INPUT:   IND-----BLOCK INDEX
  1356. C     OUTPUT:  BLKLOC--ADDRESS OF 1,1 ENTRY FOR THE BLOCK
  1357.         Include INCORE.BLK
  1358.         Include RIMCOM.BLK
  1359.       KS = BLOCKS(1,IND)
  1360.       IF(KS.EQ.0) GO TO 7500
  1361.       BLKLOC = KS
  1362.       RETURN
  1363. C
  1364. C  UNDEFINED BLOCK.
  1365. C
  1366.  7500 CONTINUE
  1367.       RMSTAT = 1002
  1368.       BLKLOC = 0
  1369.       RETURN
  1370.       END
  1371.       SUBROUTINE BLKMOV(TO,FROM,NWORDS)
  1372.         Include TEXT.BLK
  1373. C
  1374. C  PURPOSE:   MOVE WORDS BETWEEN ARRAYS
  1375. C
  1376.       INTEGER TO(1),FROM(1)
  1377.       IF(NWORDS.LT.0) GO TO 200
  1378. C
  1379. C  MOVE FROM THE FRONT OF THE ARRAYS.
  1380. C
  1381.       DO 100 I=1,NWORDS
  1382.       TO(I) = FROM(I)
  1383.   100 CONTINUE
  1384.       RETURN
  1385. C
  1386. C  MOVE FROM THE REAR OF THE ARRAYS.
  1387. C
  1388.   200 CONTINUE
  1389.       NW = -NWORDS
  1390.       DO 300 I=1,NW
  1391.       TO(NW+1-I) = FROM(NW+1-I)
  1392.   300 CONTINUE
  1393.       RETURN
  1394.       END
  1395.       SUBROUTINE BTADD(VALU,IPTR,TYPE)
  1396.         Include TEXT.BLK
  1397. C
  1398. C  PURPOSE:   ADD NEW VALUES TO A BTREE
  1399. C
  1400. C  PARAMETERS
  1401. C    INPUT:  VALU----KEY VALUE TO PROCESS
  1402. C            IPTR----POINTER TO TUPLE HAVING THIS KEY VALUE
  1403. C            TYPE----TYPE OF VARIABLE BEING ADDED
  1404. C
  1405. C  SUBROUTINES USED
  1406. C         BTGET---PAGING ROUTINE
  1407. C         BTSERT--USED TO INSERT VALUES IN A BTREE
  1408. C         BTPUT---PAGING ROUTINE
  1409. C
  1410.         Include RMATTS.BLK
  1411.         Include F3COM.BLK
  1412.         Include MISC.BLK
  1413.         Include RIMCOM.BLK
  1414.         Include BTBUF.BLK
  1415.         Include START.BLK
  1416.         Include STACK.BLK
  1417. C
  1418.       INTEGER VAL,VALT,VALU(1)
  1419.       REAL RVAL
  1420.       EQUIVALENCE (RVAL,VAL)
  1421.       INTEGER TYPE
  1422. C
  1423. C  INITIAL START OF THE SCAN.
  1424. C
  1425.       SP = 0
  1426.       KSTART = START
  1427.       VAL = VALU(1)
  1428.       ITYPE = TYPE
  1429.       IF(TYPE.EQ.KZTEXT) ITYPE = KZINT
  1430.       IP = IPTR
  1431.   100 CONTINUE
  1432.       SP = SP + 1
  1433.       STACK(SP) = KSTART
  1434. C
  1435. C  FETCH A NODE.
  1436. C
  1437.       CALL BTGET(KSTART,IN)
  1438.       KEND = IN + (LENBF3/3) - 1
  1439. C
  1440. C  LOOP THROUGH A NODE.
  1441. C
  1442.       DO 300 J=IN,KEND
  1443. C
  1444. C  CHECK FOR END-OF-LIST WORD.
  1445. C
  1446.       IF(VALUE(1,J).EQ.ENDWRD) GO TO 200
  1447. C
  1448. C  IF THE VALUE IS LT VAL THEN KEEP LOOKING.
  1449. C
  1450.       IF((ITYPE.EQ.KZINT).AND.(VALUE(1,J).LT.VAL)) GO TO 300
  1451.       IF((ITYPE.NE.KZINT).AND.(RVALUE(1,J).LT.RVAL)) GO TO 300
  1452. C
  1453. C  FOUND A BIGGER VALUE.
  1454. C
  1455.   200 CONTINUE
  1456. C
  1457. C  GO TO THE NEXT BRANCH IF THERE IS ONE.
  1458. C
  1459.       IF(VALUE(2,J).GE.0) GO TO 400
  1460.       KSTART = -VALUE(2,J)
  1461.       GO TO 100
  1462.   300 CONTINUE
  1463. C
  1464. C  WE DID NOT FIND THE END-OF-LIST WORD. DISASTER.
  1465. C
  1466.       GO TO 1000
  1467. C
  1468. C  ADD IT BETWEEN EXISTING VALUES.
  1469. C
  1470.   400 CONTINUE
  1471. C
  1472. C  CHECK FOR A DUPLICATE VALUE.
  1473. C
  1474.       IF(VALUE(1,J).NE.VAL) GO TO 500
  1475. C
  1476. C  WE HAVE A MULTIPLE VALUE. SEE IF THIS IS THE FIRST DUPLICATE.
  1477. C
  1478.       IF(VALUE(3,J).NE.0) GO TO 420
  1479. C
  1480. C  DO SPECIAL PROCESSING FOR THE FIRST MULTIPLE VALUE.
  1481. C
  1482.       IPTR1 = VALUE(2,J)
  1483.       IF(MOTADD.LT.LENBF3) GO TO 410
  1484.       MOTADD = 0
  1485.       MOTREC = LF3REC
  1486.       CALL BTGET(MOTREC,IN)
  1487.       LF3REC = LF3REC + 1
  1488.   410 CONTINUE
  1489.       CALL HTOI(MOTADD+1,MOTREC,KWORD)
  1490.       VALUE(3,J) = KWORD
  1491.       VALUE(2,J) = KWORD
  1492.       CALL BTPUT(STACK(SP))
  1493. C
  1494. C  ADD THE FIRST LINK TO THE MOT.
  1495. C
  1496.       CALL BTGET(MOTREC,IN)
  1497.       MOTIND = 3 * IN - 3
  1498.       MOTADD = MOTADD + 1
  1499.       MOTIND = MOTIND + MOTADD
  1500.       CORE(MOTIND+1) = IPTR1
  1501.       MOTADD = MOTADD + 1
  1502.       CALL BTPUT(MOTREC)
  1503.   420 CONTINUE
  1504. C
  1505. C  FIX UP THE END POINTER.
  1506. C
  1507.       IF(MOTADD.LT.LENBF3) GO TO 430
  1508.       MOTADD = 0
  1509.       MOTREC = LF3REC
  1510.       CALL BTGET(MOTREC,IN)
  1511.       LF3REC = LF3REC + 1
  1512.   430 CONTINUE
  1513.       CALL ITOH(MOTIND,MOTID,VALUE(2,J))
  1514.       CALL HTOI(MOTADD+1,MOTREC,VALUE(2,J))
  1515.       CALL BTPUT(STACK(SP))
  1516. C
  1517. C  GET THE END OF THE MOT TRAIL.
  1518. C
  1519.       CALL BTGET(MOTID,IN)
  1520.       IN = 3 * IN - 3
  1521.       MOTIND = MOTIND + IN
  1522. C
  1523. C  ADD THE NEXT LINK IN THE MOT.
  1524. C
  1525.       MOTADD = MOTADD + 1
  1526.       CALL HTOI(MOTADD,MOTREC,KWORD)
  1527.       CORE(MOTIND) = KWORD
  1528.       CALL BTPUT(MOTID)
  1529. C
  1530. C  NOW ADD THE POINTER TO THE MOT.
  1531. C
  1532.       CALL BTGET(MOTREC,IN)
  1533.       IN = 3 * IN - 3
  1534.       MOTADD = MOTADD + 1
  1535.       MOTIND = IN + MOTADD
  1536.       CORE(MOTIND) = IPTR
  1537.       CALL BTPUT(MOTREC)
  1538.       RETURN
  1539. C
  1540. C  THIS VALUE IS NOT IN THE BTREE YET.
  1541. C
  1542.   500 CONTINUE
  1543. C
  1544. C  CALL BTSERT TO INSERT THE DATA.
  1545. C
  1546.       VALT = VAL
  1547.       IPT = IP
  1548.   600 CONTINUE
  1549.       CALL BTSERT(VALT,IPT,STACK,SP,J,IN)
  1550.       IF(SP.EQ.0) RETURN
  1551. C
  1552. C  FETCH THE NEXT NODE UP THE STACK.
  1553. C
  1554.       CALL BTGET(STACK(SP),IN)
  1555. C
  1556. C  CALCULATE A NEW VALUE FOR J.
  1557. C
  1558.       KEND = IN + (LENBF3/3) - 1
  1559.       DO 700 J=IN,KEND
  1560.       IF(VALUE(1,J).EQ.ENDWRD) GO TO 600
  1561.       IF((ITYPE.EQ.KZINT).AND.(VALUE(1,J).LT.VAL)) GO TO 700
  1562.       IF((ITYPE.NE.KZINT).AND.(RVALUE(1,J).LT.RVAL)) GO TO 700
  1563. C
  1564. C  WE FOUND A BIGGER VALUE.
  1565. C
  1566.       GO TO 600
  1567.   700 CONTINUE
  1568. C
  1569. C  SOMETHING IS WRONG. WE CANNOT FIND A LARGER VALUE.
  1570. C
  1571.       RMSTAT = 1003
  1572.       RETURN
  1573. C
  1574. C  LOOKUP FOR A VALUE NOT IN THE TREE.
  1575. C
  1576.  1000 CONTINUE
  1577.       RETURN
  1578.       END
  1579.       SUBROUTINE BTGET(ID,NSTRT)
  1580.         Include TEXT.BLK
  1581. C
  1582. C  PURPOSE:    RETREIVE OR SET UP A BTREE OR MOT NODE.
  1583. C
  1584. C  PARAMETERS
  1585. C     INPUT:   ID------DESIRED RECORD NUMBER
  1586. C     OUTPUT:  NSTRT---BUFFER INDEX FOR REQUESTED NODE
  1587. C
  1588.         Include BTBUF.BLK
  1589.         Include RIMCOM.BLK
  1590.         Include F3COM.BLK
  1591. C
  1592. C  SEE IF THE BLOCK IS IN CORE.
  1593. C
  1594.       DO 100 NUMB=1,NUMIC
  1595.       IF(ID.EQ.ICORE(3,NUMB)) GO TO 1000
  1596.   100 CONTINUE
  1597. C
  1598. C  THE REQUESTED BLOCK IS NOT IN THE BUFFER.
  1599. C
  1600. C   DETERMINE WHICH SLOT IN THE BUFFER WE SHOULD USE.
  1601. C
  1602.       IF(NUMIC.GE.MAXIC) GO TO 200
  1603. C
  1604. C  STILL ROOM IN THE BUFFER.
  1605. C
  1606.       NUMIC = NUMIC + 1
  1607.       NUMB = NUMIC
  1608.       GO TO 500
  1609. C
  1610. C  WE MUST DETERMINE WHO WILL BE MOVED OUT.
  1611. C
  1612.   200 CONTINUE
  1613.       MINUMB = 1
  1614.       IF(MINUMB.EQ.LAST) MINUMB = 2
  1615.       MINUSE = ICORE(1,MINUMB)
  1616.       DO 300 NUMB=1,NUMIC
  1617.       IF(NUMB.EQ.LAST) GO TO 300
  1618.       NUMUSE = ICORE(1,NUMB)
  1619.       IF(NUMUSE.EQ.0) GO TO 400
  1620.       IF(NUMUSE.GT.MINUSE) GO TO 300
  1621.       MINUSE = NUMUSE
  1622.       MINUMB = NUMB
  1623.   300 CONTINUE
  1624. C
  1625. C  USE THE BLOCK THAT WAS USED THE LEAST.
  1626. C
  1627.       NUMB = MINUMB
  1628.   400 CONTINUE
  1629. C
  1630. C  BLOCK NUMB WILL BE USED.
  1631. C
  1632. C  SEE IF THE BLOCK CURRENTLY THERE MUST BE WRITTEN OUT.
  1633. C
  1634.       IF(ICORE(2,NUMB).EQ.0) GO TO 500
  1635. C
  1636. C  WRITE IT OUT.
  1637. C
  1638.       ISTRT = (NUMB-1) * LENBF3 + 1
  1639.       IEND = ISTRT + LENBF3 - 1
  1640.       IOBN = ICORE(3,NUMB)
  1641.       CALL RIOOUT(FILE3,IOBN,CORE(ISTRT),LENBF3,IOS)
  1642.       IF(IOS.NE.0) RMSTAT = 2300 + IOS
  1643.   500 CONTINUE
  1644. C
  1645. C  CHANGE THE ICORE ENTRY.
  1646. C
  1647.       ICORE(3,NUMB) = ID
  1648.       ICORE(2,NUMB) = 0
  1649. C
  1650. C  READ IN DESIRED BLOCK.
  1651. C
  1652.       ISTRT = (NUMB-1) * LENBF3 + 1
  1653.       CALL RIOIN(FILE3,ID,CORE(ISTRT),LENBF3,IOS)
  1654.       IF(ID.GE.LF3REC) GO TO 600
  1655.       IF(IOS.EQ.0) GO TO 1000
  1656.   600 CONTINUE
  1657.       CALL ZEROIT(CORE(ISTRT),LENBF3)
  1658.       CALL RIOOUT(FILE3,ID,CORE(ISTRT),LENBF3,IOS)
  1659.       IF(IOS.NE.0) RMSTAT = 2300 + IOS
  1660. C
  1661. C  UPDATE THE ICORE ARRAY AND SET NSTRT.
  1662. C
  1663.  1000 CONTINUE
  1664.       ICORE(1,NUMB) = ICORE(1,NUMB) + 1
  1665.       ISTRT = ((NUMB-1) * LENBF3) / 3 + 1
  1666.       NSTRT = ISTRT
  1667.       LAST = NUMB
  1668.       RETURN
  1669.       END
  1670.       SUBROUTINE BTINIT(START)
  1671.         Include TEXT.BLK
  1672. C
  1673. C  PURPOSE:   INITIALIZE FOR A NEW BTREE
  1674. C
  1675. C  PARAMETERS:
  1676. C         START---NEW RECORD USED FOR THIS BTREE
  1677. C
  1678.         Include F3COM.BLK
  1679.         Include MISC.BLK
  1680.         Include BTBUF.BLK
  1681. C
  1682.       INTEGER START
  1683. C
  1684. C  GET THE NEXT NODE.
  1685. C
  1686.       CALL BTGET(LF3REC,N1)
  1687. C
  1688. C  INSERT THE END-OF-LIST WORD.
  1689. C
  1690.       VALUE(1,N1) = ENDWRD
  1691.       VALUE(2,N1) = 1
  1692.       VALUE(3,N1) = 0
  1693. C
  1694. C  WRITE OUT THIS NODE.
  1695. C
  1696.       CALL BTPUT(LF3REC)
  1697.       START = LF3REC
  1698.       LF3REC = LF3REC + 1
  1699.       RETURN
  1700.       END
  1701.       SUBROUTINE BTLKI(VAL,IPTR,MOTID)
  1702.         Include TEXT.BLK
  1703. C
  1704. C  PURPOSE:  LOOKUP PROCESSING ROUTINE FOR BTREES
  1705. C
  1706. C  PARAMETERS
  1707. C    INPUT:  VAL-----KEY VALUE TO PROCESS
  1708. C            IPTR----POINTER TO TUPLE HAVING THIS KEY VALUE
  1709. C            MOTID---MOT LINK
  1710. C
  1711. C  SUBROUTINES USED
  1712. C         BTGET---PAGING ROUTINE
  1713. C
  1714.         Include F3COM.BLK
  1715.         Include MISC.BLK
  1716.         Include BTBUF.BLK
  1717.         Include START.BLK
  1718. C
  1719.       INTEGER VAL
  1720. C
  1721. C  SET UP VARIABLES BASED ON THE ENTRY POINT.
  1722. C
  1723. C
  1724. C  INITIAL START OF THE SCAN.
  1725. C
  1726.       KSTART = START
  1727.   100 CONTINUE
  1728. C
  1729. C  FETCH A NODE.
  1730. C
  1731.       CALL BTGET(KSTART,IN)
  1732.       KEND = IN + (LENBF3/3) - 1
  1733.  
  1734. C
  1735. C  LOOP THROUGH A NODE.
  1736. C
  1737.       DO 300 J=IN,KEND
  1738. C
  1739. C  CHECK FOR END-OF-LIST WORD.
  1740. C
  1741.       IF(VALUE(1,J).EQ.ENDWRD) GO TO 200
  1742. C
  1743. C  IF THE VALUE IS LT VAL THEN KEEP LOOKING.
  1744. C
  1745.       IF(VALUE(1,J).LT.VAL) GO TO 300
  1746. C
  1747. C  FOUND A BIGGER VALUE.
  1748. C
  1749.   200 CONTINUE
  1750. C
  1751. C  GO TO THE NEXT BRANCH IF THERE IS ONE.
  1752. C
  1753.       IF(VALUE(2,J).GE.0) GO TO 400
  1754.       KSTART = -VALUE(2,J)
  1755.       GO TO 100
  1756.   300 CONTINUE
  1757. C
  1758. C  WE DID NOT FIND THE END-OF-LIST WORD. DISASTER.
  1759. C
  1760.       GO TO 500
  1761. C
  1762. C  DONE SCANNING THE BTREE.
  1763. C
  1764.   400 CONTINUE
  1765. C
  1766. C  CHECK FOR AN EQUAL VALUE.
  1767. C
  1768.       IF(VALUE(1,J).NE.VAL) GO TO 500
  1769. C
  1770. C  PROCESS WAS A LOOKUP. RETURN THE TUPLE POINTER.
  1771. C
  1772.       IPTR = VALUE(2,J)
  1773.       MOTID = VALUE(3,J)
  1774.       IF(MOTID.NE.0) CALL MOTSCN(MOTID,IPTR)
  1775.       RETURN
  1776. C
  1777. C  THIS VALUE IS NOT IN THE BTREE YET.
  1778. C
  1779.   500 CONTINUE
  1780.       IPTR = 0
  1781.       MOTID = 0
  1782.       RETURN
  1783.       END
  1784.       SUBROUTINE BTLKR(VAL,IPTR,MOTID)
  1785.         Include TEXT.BLK
  1786. C
  1787. C  PURPOSE:  LOOKUP PROCESSING ROUTINE FOR BTREES
  1788. C
  1789. C  PARAMETERS
  1790. C    INPUT:  VAL-----KEY VALUE TO PROCESS
  1791. C            IPTR----POINTER TO TUPLE HAVING THIS KEY VALUE
  1792. C            MOTID---MOT LINK
  1793. C
  1794. C  SUBROUTINES USED
  1795. C         BTGET---PAGING ROUTINE
  1796. C
  1797.         Include F3COM.BLK
  1798.         Include MISC.BLK
  1799.         Include BTBUF.BLK
  1800.         Include START.BLK
  1801. C
  1802.       REAL VAL
  1803. C
  1804. C  SET UP VARIABLES BASED ON THE ENTRY POINT.
  1805. C
  1806. C
  1807. C  INITIAL START OF THE SCAN.
  1808. C
  1809.       KSTART = START
  1810.   100 CONTINUE
  1811. C
  1812. C  FETCH A NODE.
  1813. C
  1814.       CALL BTGET(KSTART,IN)
  1815.       KEND = IN + (LENBF3/3) - 1
  1816. C
  1817. C  LOOP THROUGH A NODE.
  1818. C
  1819.       DO 300 J=IN,KEND
  1820. C
  1821. C  CHECK FOR END-OF-LIST WORD.
  1822. C
  1823.       IF(VALUE(1,J).EQ.ENDWRD) GO TO 200
  1824. C
  1825. C  IF THE VALUE IS LT VAL THEN KEEP LOOKING.
  1826. C
  1827.       IF(RVALUE(1,J).LT.VAL) GO TO 300
  1828. C
  1829. C  FOUND A BIGGER VALUE.
  1830. C
  1831.   200 CONTINUE
  1832. C
  1833. C  GO TO THE NEXT BRANCH IF THERE IS ONE.
  1834. C
  1835.       IF(VALUE(2,J).GE.0) GO TO 400
  1836.       KSTART = -VALUE(2,J)
  1837.       GO TO 100
  1838.   300 CONTINUE
  1839. C
  1840. C  WE DID NOT FIND THE END-OF-LIST WORD. DISASTER.
  1841. C
  1842.       GO TO 500
  1843. C
  1844. C  DONE SCANNING THE BTREE.
  1845. C
  1846.   400 CONTINUE
  1847. C
  1848. C  CHECK FOR AN EQUAL VALUE.
  1849. C
  1850.       IF(RVALUE(1,J).NE.VAL) GO TO 500
  1851. C
  1852. C  PROCESS WAS A LOOKUP. RETURN THE TUPLE POINTER.
  1853. C
  1854.       IPTR = VALUE(2,J)
  1855.       MOTID = VALUE(3,J)
  1856.       IF(MOTID.NE.0) CALL MOTSCN(MOTID,IPTR)
  1857.       RETURN
  1858. C
  1859. C  THIS VALUE IS NOT IN THE BTREE YET.
  1860. C
  1861.   500 CONTINUE
  1862.       IPTR = 0
  1863.       MOTID = 0
  1864.       RETURN
  1865.       END
  1866.       SUBROUTINE BTLKT(VAL,IPTR,MOTID)
  1867.         Include TEXT.BLK
  1868. C
  1869. C  PURPOSE:  LOOKUP PROCESSING ROUTINE FOR BTREES
  1870. C
  1871. C  PARAMETERS:
  1872. C    INPUT:  VAL-----KEY VALUE TO PROCESS
  1873. C            IPTR----POINTER TO TUPLE HAVING THIS KEY VALUE
  1874. C            MOTID---MOT LINK
  1875. C
  1876. C  HASH THE TEXT STRING INTO AN INTEGER AND CALL BTLKI.
  1877. C
  1878.       INTEGER VAL(1)
  1879.       IVAL = VAL(1)
  1880.       CALL BTLKI(IVAL,IPTR,MOTID)
  1881.       RETURN
  1882.       END
  1883.       SUBROUTINE BTMOVE(NEW,OLD,NV)
  1884.         Include TEXT.BLK
  1885. C
  1886. C  PURPOSE:   MOVE NV VALUES FROM OLD TO NEW.
  1887. C
  1888.         Include BTBUF.BLK
  1889.       INTEGER OLD
  1890.       IS = 1
  1891.       IF(NV.LT.0) IS = -1
  1892.       N = IS * NV
  1893.       DO 100 I=1,N
  1894.       IN = NEW + IS * (I - 1)
  1895.       IO = OLD + IS * (I - 1)
  1896.       VALUE(1,IN) = VALUE(1,IO)
  1897.       VALUE(2,IN) = VALUE(2,IO)
  1898.       VALUE(3,IN) = VALUE(3,IO)
  1899.   100 CONTINUE
  1900.       RETURN
  1901.       END
  1902.       SUBROUTINE BTPUT(ID)
  1903.         Include TEXT.BLK
  1904. C
  1905. C  PURPOSE:    TURN ON THE WRITE FLAG ON THE INDICATED BLOCK
  1906. C
  1907. C  PARAMETERS
  1908. C     INPUT:   ID------RECORD NUMBER
  1909.         Include F3COM.BLK
  1910.         Include RIMCOM.BLK
  1911.         Include FLAGS.BLK
  1912. C
  1913. C  LOOK FOR THIS BLOCK IN CORE.
  1914. C
  1915.       DO 100 NUMB=1,NUMIC
  1916.       IF(ID.EQ.ICORE(3,NUMB)) GO TO 200
  1917.   100 CONTINUE
  1918. C
  1919. C  DISASTER. WE CANNOT FIND THE BLOCK.
  1920. C
  1921.       RMSTAT = 1004
  1922.       RETURN
  1923. C
  1924. C  SET THE WRITE FLAG.
  1925. C
  1926.   200 CONTINUE
  1927.       ICORE(2,NUMB) = 1
  1928.       IFMOD = .TRUE.
  1929.       RETURN
  1930.       END
  1931.       SUBROUTINE BTREP(VALU,IPTR,IPTRO,TYPE)
  1932.         Include TEXT.BLK
  1933. C
  1934. C  PURPOSE:   REPLACE VALUES IN A BTREE
  1935. C
  1936. C  PARAMETERS
  1937. C    INPUT:  VALU----KEY VALUE TO PROCESS
  1938. C         IPTR----NEW POINTER TO BE USED
  1939. C         IPTRO---OLD POINTER TO BE REPLACED
  1940. C         TYPE----TYPE OF VARIABLE BEING ADDED
  1941. C
  1942. C
  1943. C  SUBROUTINES USED
  1944. C         BTGET---PAGING ROUTINE
  1945. C         BTPUT---PAGING ROUTINE
  1946. C
  1947. C  DECLARATIVES
  1948. C
  1949.         Include RMATTS.BLK
  1950.         Include F3COM.BLK
  1951.         Include MISC.BLK
  1952.         Include BTBUF.BLK
  1953.         Include START.BLK
  1954.         Include STACK.BLK
  1955. C
  1956.       INTEGER VAL,VALU(1)
  1957.       REAL RVAL
  1958.       EQUIVALENCE (RVAL,VAL)
  1959.       INTEGER TYPE
  1960. C
  1961. C  INITIAL START OF THE SCAN.
  1962. C
  1963.       SP = 0
  1964.       KSTART = START
  1965.       VAL = VALU(1)
  1966.       ITYPE = TYPE
  1967.       IF(TYPE.EQ.KZTEXT) ITYPE = KZINT
  1968.       IP = IPTR
  1969.   100 CONTINUE
  1970.       SP = SP + 1
  1971.       STACK(SP) = KSTART
  1972. C
  1973. C  FETCH A NODE.
  1974. C
  1975.       CALL BTGET(KSTART,IN)
  1976.       KEND = IN + (LENBF3/3) - 1
  1977. C
  1978. C  LOOP THROUGH A NODE.
  1979. C
  1980.       DO 300 J=IN,KEND
  1981. C
  1982. C  CHECK FOR END-OF-LIST WORD.
  1983. C
  1984.       IF(VALUE(1,J).EQ.ENDWRD) GO TO 200
  1985. C
  1986. C  IF THE VALUE IS LT VAL THEN KEEP LOOKING.
  1987. C
  1988.       IF((ITYPE.EQ.KZINT).AND.(VALUE(1,J).LT.VAL)) GO TO 300
  1989.       IF((ITYPE.NE.KZINT).AND.(RVALUE(1,J).LT.RVAL)) GO TO 300
  1990. C
  1991. C  FOUND A BIGGER VALUE.
  1992. C
  1993.   200 CONTINUE
  1994. C
  1995. C  GO TO THE NEXT BRANCH IF THERE IS ONE.
  1996. C
  1997.       IF(VALUE(2,J).GE.0) GO TO 400
  1998.       KSTART = -VALUE(2,J)
  1999.       GO TO 100
  2000.   300 CONTINUE
  2001. C
  2002. C  WE DID NOT FIND THE END-OF-LIST WORD. DISASTER.
  2003. C
  2004.       GO TO 1000
  2005. C
  2006. C  END OF THE BTREE SEARCH.
  2007. C
  2008.   400 CONTINUE
  2009. C
  2010. C  CHECK FOR A DUPLICATE VALUE.
  2011. C
  2012.       IF(VALUE(1,J).NE.VAL) GO TO 1000
  2013.       IF(VALUE(3,J).NE.0) GO TO 450
  2014.       IF(VALUE(2,J).NE.IPTRO) GO TO 450
  2015.       VALUE(2,J) = IPTR
  2016.       CALL BTPUT(KSTART)
  2017.       GO TO 1000
  2018.   450 CONTINUE
  2019. C
  2020. C  WE HAVE A MULTIPLE VALUE. FOLLOW THE LINKS.
  2021. C
  2022. C  GET THE MOT NODE.
  2023. C
  2024.       MOTIND = 3 * J
  2025.       MOTIDP = STACK(SP)
  2026.       IF(VALUE(3,J).EQ.0) GO TO 1000
  2027.       CALL ITOH(MOTIND,MOTID,VALUE(3,J))
  2028. C
  2029. C  MOT LINK TRAIL.
  2030. C
  2031.   460 CONTINUE
  2032.       CALL BTGET(MOTID,IN)
  2033.       IN = 3 * IN - 3
  2034.       MOTIDP = MOTID
  2035.   470 CONTINUE
  2036.       MOTIND = MOTIND + IN
  2037.       IF(CORE(MOTIND+1).EQ.IPTRO) GO TO 500
  2038.       IF(CORE(MOTIND).EQ.0) GO TO 1000
  2039.       CALL ITOH(MOTIND,MOTID,CORE(MOTIND))
  2040. C
  2041. C  SEE IF WE ARE ON THE SAME MOT PAGE.
  2042. C
  2043.       IF(MOTID.EQ.MOTIDP) GO TO 470
  2044.       GO TO 460
  2045. C
  2046. C  REPLACE THE POINTER.
  2047. C
  2048.   500 CONTINUE
  2049.       CORE(MOTIND+1) = IPTR
  2050.       CALL BTPUT(MOTIDP)
  2051.       RETURN
  2052. C
  2053. C  LOOKUP FOR A VALUE NOT IN THE TREE.
  2054. C
  2055.  1000 CONTINUE
  2056.       RETURN
  2057.       END
  2058.       SUBROUTINE BTSERT(VAL,IP,STACK,SP,LOC,IN)
  2059.         Include TEXT.BLK
  2060. C
  2061. C  INSERT VAL INTO LOC REFERENCED BY THE STACK POINTER.
  2062. C
  2063. C  SUBROUTINES USED
  2064. C         BTGET---PAGING ROUTINE
  2065. C         BTPUT---PAGING ROUTINE
  2066. C         BTMOVE--MOVES DATA BETWEEN AREAS
  2067. C
  2068.         Include F3COM.BLK
  2069.         Include BTBUF.BLK
  2070.         Include START.BLK
  2071.       INTEGER VALT
  2072.       INTEGER VAL,STACK(1),SP
  2073. C
  2074.       KEND = IN + (LENBF3/3) - 1
  2075.       J = LOC
  2076. C
  2077. C  CHECK TO SEE IF THE NODE IS ALREADY FULL.
  2078. C
  2079.       IF(VALUE(2,KEND).NE.0) GO TO 100
  2080. C
  2081. C  STILL ROOM.
  2082. C
  2083.       NV = KEND - J
  2084.       CALL BTMOVE(KEND,KEND-1,-NV)
  2085.       VALUE(1,J) = VAL
  2086.       VALUE(2,J) = IP
  2087.       VALUE(3,J) = 0
  2088. C
  2089. C  WRITE OUT THIS NODE.
  2090. C
  2091.       CALL BTPUT(STACK(SP))
  2092.       SP = 0
  2093.       RETURN
  2094. C
  2095. C  WE NEED TO SPLIT THE NODE. SAVE THE CURRENT LAST VALUE.
  2096. C
  2097.   100 CONTINUE
  2098.       VALT = VALUE(1,KEND)
  2099.       IBT = VALUE(2,KEND)
  2100.       IMT = VALUE(3,KEND)
  2101. C
  2102. C  PUT THE NEW VALUE IN ITS PLACE.
  2103. C
  2104.       NV = KEND - J
  2105.       CALL BTMOVE(KEND,KEND-1,-NV)
  2106.       VALUE(1,J) = VAL
  2107.       VALUE(2,J) = IP
  2108.       VALUE(3,J) = 0
  2109. C
  2110. C  NEW VALUE IS IN
  2111. C
  2112. C  MOVE THE LOW PART
  2113. C
  2114.       NV = 2 * (LENBF3/3) / 3
  2115.       CALL BTGET(LF3REC,N2)
  2116.       CALL BTMOVE(N2,IN,NV)
  2117. C
  2118. C  WRITE OUT THIS NEW NODE.
  2119. C
  2120.       CALL BTPUT(LF3REC)
  2121.       L = N2 + NV - 1
  2122. C
  2123. C  SAVE IN A NEW NODE POINTER.
  2124. C
  2125.       VAL = VALUE(1,L)
  2126.       IP = -LF3REC
  2127. C
  2128. C  MOVE THE TOP OF THE OLD NODE TO THE BOTTOM.
  2129. C
  2130.       NV = (LENBF3/3) - NV
  2131.       CALL BTMOVE(IN,KEND-NV+1,NV)
  2132. C
  2133. C  RESTORE THE OLD LAST VALUE.
  2134. C
  2135.       L = NV
  2136.       VALUE(1,IN+L) = VALT
  2137.       VALUE(2,IN+L) = IBT
  2138.       VALUE(3,IN+L) = IMT
  2139. C
  2140. C  ZERO OUT THE REMAINDER OF THE NODE.
  2141. C
  2142.       NV = (LENBF3/3) - NV - 1
  2143.       IF(NV.LE.0) GO TO 300
  2144.       J = 3 * (KEND - IN - L)
  2145.       CALL ZEROIT(VALUE(1,IN+L+1),J)
  2146.   300 CONTINUE
  2147. C
  2148. C  WRITE OUT THIS NODE AGAIN.
  2149. C
  2150.       CALL BTPUT(STACK(SP))
  2151.       SP = SP - 1
  2152.       LF3REC = LF3REC + 1
  2153.       IF(SP.NE.0) RETURN
  2154. C
  2155. C  NEW STARTING NODE.
  2156. C
  2157.       CALL BTGET(LF3REC,N1)
  2158.       VALUE(1,N1) = VAL
  2159.       VALUE(2,N1) = IP
  2160.       VALUE(3,N1) = 0
  2161.       VALUE(1,N1+1) = VALT
  2162.       VALUE(2,N1+1) = -STACK(1)
  2163.       VALUE(3,N1+1) = 0
  2164.       CALL REUSE
  2165. C
  2166. C  WRITE OUT THIS NEW NODE.
  2167. C
  2168.       CALL BTPUT(LF3REC)
  2169.       START = LF3REC
  2170.       LF3REC = LF3REC + 1
  2171.       RETURN
  2172.       END
  2173.       SUBROUTINE BUILD
  2174.         Include TEXT.BLK
  2175. C
  2176. C  PURPOSE:  BUILD A KEY INDEX FOR AN ATTRIBUTE IN A RELATION
  2177. C
  2178.         Include RMATTS.BLK
  2179.         Include RMKEYW.BLK
  2180.         Include RIMPTR.BLK
  2181.         Include TUPLEA.BLK
  2182.         Include TUPLER.BLK
  2183.         Include BUFFER.BLK
  2184.         Include START.BLK
  2185.         Include FILES.BLK
  2186.         Include RIMCOM.BLK
  2187.         Include FLAGS.BLK
  2188.         Include MISC.BLK
  2189.         Include WHCOM.BLK
  2190.         Include SRTCOM.BLK
  2191.         Include DCLAR1.BLK
  2192.       INTEGER COLUMN
  2193. C
  2194.       LOGICAL EQKEYW
  2195. C
  2196. C  SCAN THE COMMAND FOR PROPER SYNTAX.
  2197. C
  2198.       IF(.NOT.EQKEYW(2,KWKEY,3)) GO TO 7500
  2199.       IF(.NOT.EQKEYW(3,KWFOR,3)) GO TO 7500
  2200.       IF(.NOT.EQKEYW(5,KWIN,2)) GO TO 7500
  2201.       IF(LXITEM(DUM).GT.6) GO TO 7500
  2202. C
  2203. C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
  2204. C
  2205.       CALL RMDBLK(DBNAME)
  2206.       IF(RMSTAT.EQ.0) GO TO 50
  2207.       CALL WARN(RMSTAT,DBNAME,0)
  2208.       GO TO 8000
  2209. C
  2210. C  FIND THE ATTRIBUTE IN THE SPECIFIED RELATION.
  2211. C
  2212.    50 CONTINUE
  2213.       RNAME = BLANK
  2214.       CALL LXSREC(6,1,8,RNAME,1)
  2215.       ANAME = BLANK
  2216.       CALL LXSREC(4,1,8,ANAME,1)
  2217.       I = LOCREL(RNAME)
  2218.       IF(I.EQ.0) GO TO 100
  2219. C
  2220. C  UNRECOGIZED RELATION NAME.
  2221. C
  2222.       CALL WARN(1,RNAME,0)
  2223.       GO TO 8000
  2224.   100 CONTINUE
  2225. C
  2226. C  CHECK FOR MODIFY PERMISSION.
  2227. C
  2228.       I = LOCPRM(RNAME,2)
  2229.       IF(I.EQ.0) GO TO 150
  2230.       CALL WARN(9,RNAME,0)
  2231.       GO TO 8000
  2232. C
  2233. C  FIND THE ATTRIBUTE IN THE RELATION.
  2234. C
  2235.   150 CONTINUE
  2236.       I = LOCATT(ANAME,RNAME)
  2237.       IF(I.EQ.0) GO TO 200
  2238. C
  2239. C  THIS ATTRIBUTE IS NOT IN THIS RELATION.
  2240. C
  2241.       CALL WARN(3,ANAME,RNAME)
  2242.       GO TO 8000
  2243.   200 CONTINUE
  2244. C
  2245. C  ISSUE A WARNING IF ATTRIBUTE IS ALREADY A KEY.
  2246. C
  2247.       CALL ATTGET(ISTAT)
  2248.       IF(ATTKEY.EQ.0) GO TO 400
  2249.       WRITE(NOUT,300) ANAME
  2250.   300 FORMAT(19H -ERROR- ATTRIBUTE ,A8,
  2251.      X       17H IS ALREADY A KEY )
  2252.       GO TO 8000
  2253.   400 CONTINUE
  2254. C
  2255. C  DETERMINE THE COLUMN TO BE USED FOR THIS ATTRIBUTE.
  2256. C
  2257.       COLUMN = ATTCOL
  2258. C
  2259. C  INITIALIZE THE BTREE FOR THIS ELEMENT.
  2260. C
  2261.       CALL BTINIT(ATTKEY)
  2262.       START = ATTKEY
  2263.       CALL ATTPUT(ISTAT)
  2264. C
  2265. C  SORT THE KEY VALUES IF THERE ARE MORE THAN 100 OF THEM
  2266. C
  2267.       IF(NTUPLE.GT.100) GO TO 700
  2268. C
  2269. C   SCAN THROUGH ALL THE DATA FOR THIS RELATION.
  2270. C
  2271.   500 CONTINUE
  2272.       IF(NID.EQ.0) GO TO 900
  2273.       CID = NID
  2274.       CALL GETDAT(1,NID,ITUP,LENGTH)
  2275.       IF(NID.LT.0) GO TO 900
  2276.       IP = ITUP + COLUMN - 1
  2277.       IF(ATTWDS.NE.0) GO TO 600
  2278. C
  2279. C  ATTRIBUTE IS A VARIABLE LENGTH ATTRIBUTE.
  2280. C
  2281.       IP = BUFFER(IP) + ITUP + 1
  2282.   600 CONTINUE
  2283.       IF(BUFFER(IP).EQ.NULL) GO TO 500
  2284.       CALL BTADD(BUFFER(IP),CID,ATTYPE)
  2285.       GO TO 500
  2286. C
  2287. C  SORT KEY VALUES BEFORE BUILDING THE B-TREE
  2288. C
  2289.   700 CONTINUE
  2290.       LENGTH = 2
  2291.       NSOVAR = 1
  2292.       NKSORT = 3
  2293.       LIMTU = ALL9S
  2294.       SORTYP(1) = .TRUE.
  2295.       VARPOS(1) = 1
  2296.       L = 2
  2297.       IF(ATTYPE.EQ.KZTEXT) L = 4
  2298.       IF(ATTYPE.EQ.KZINT ) L = 1
  2299.       IF(ATTYPE.EQ.KZIVEC) L = 1
  2300.       IF(ATTYPE.EQ.KZIMAT) L = 1
  2301.       VARTYP(1) = L
  2302.       CALL SORT(NKSORT,IERR)
  2303.       IF(IERR.EQ.0)GOTO 770
  2304.       WRITE(NOUT,1770)
  2305.  1770 FORMAT(36H ERROR -- COULD NOT OPEN SORTFIL.DAT)
  2306.       GOTO 8000
  2307.   770 CONTINUE
  2308. C
  2309. C  READ THE SORTED KEY VALUES AND BUILD THE BTREE
  2310. C
  2311.       CALL GTSORT(IP,1,-1,LENGTH)
  2312.   800 CONTINUE
  2313.       CALL GTSORT(IP,1,1,LENGTH)
  2314.       IF(RMSTAT.NE.0) GO TO 900
  2315.       IF(BUFFER(IP).EQ.NULL) GO TO 800
  2316.       CALL BTADD(BUFFER(IP),BUFFER(IP+1),ATTYPE)
  2317.       GO TO 800
  2318. C
  2319. C  ALL DONE.
  2320. C
  2321.   900 CONTINUE
  2322. C
  2323. C  RESTORE THE START TO THE BTREE TABLE.
  2324. C
  2325.       I = LOCATT(ANAME,RNAME)
  2326.       CALL ATTGET(ISTAT)
  2327.       ATTKEY = START
  2328.       CALL ATTPUT(ISTAT)
  2329.       GO TO 8000
  2330. C
  2331. C  SYNTAX ERROR.
  2332. C
  2333.  7500 CONTINUE
  2334.       CALL WARN(4,0,0)
  2335. C
  2336. C  RETURN
  2337. C
  2338.  8000 RETURN
  2339.       END
  2340.       SUBROUTINE CHANGE(MAT,NVAL)
  2341.         Include TEXT.BLK
  2342. C
  2343. C  THIS ROUTINE PROCESSES A CHANGE IN RIM.
  2344. C
  2345. C  PARAMETERS:
  2346. C         MAT-----SCRATCH ARRAY FOR A TUPLE
  2347. C         NVAL----SCRATCH ARRAY FOR A TUPLE
  2348.         Include RMATTS.BLK
  2349.         Include RMKEYW.BLK
  2350.         Include CONST4.BLK
  2351.         Include SORBUF.BLK
  2352.         Include RIMCOM.BLK
  2353.         Include RIMPTR.BLK
  2354.         Include FILES.BLK
  2355.         Include RULCOM.BLK
  2356.         Include FLAGS.BLK
  2357.         Include WHCOM.BLK
  2358.         Include BUFFER.BLK
  2359.         Include START.BLK
  2360.         Include TUPLEA.BLK
  2361.         Include TUPLER.BLK
  2362.         Include MISC.BLK
  2363. C
  2364. C  DIMENSION STATEMENTS.
  2365. C
  2366.       DIMENSION MAT(1)
  2367.       DIMENSION NVAL(1)
  2368.       INTEGER RULWHR(14)
  2369.       LOGICAL BYPASS
  2370.       INTEGER COLUMN
  2371.       LOGICAL NE
  2372.       LOGICAL SINGLE
  2373.       LOGICAL EQKEYW
  2374.       INTEGER EXTRA
  2375.         Include DCLAR1.BLK
  2376.       NC = 0
  2377.       NOPE = 0
  2378. C
  2379. C  LOOK FOR THE WORD WHERE.
  2380. C
  2381.       ITEMS = LXITEM(ISTAT)
  2382.       J = LFIND(1,ITEMS,KWWHER,5)
  2383.       IF(J.NE.0) GO TO 100
  2384.       WRITE(NOUT,9001)
  2385.  9001 FORMAT(48H -ERROR- WHERE CLAUSE REQUIRED ON CHANGE COMMAND)
  2386.       GO TO 9999
  2387.   100 CONTINUE
  2388.       NEWL = ATTWDS
  2389.       NROW = ATTCHA
  2390. C
  2391. C     SINGLE INDICATES VEC(I) MAT(I,J) SPECIFICATION
  2392. C
  2393.       SINGLE = LXWREC(3,1).EQ.K4LPAR
  2394.       IF(.NOT.SINGLE) GO TO 200
  2395. C
  2396. C     CHECK SINGLE SYNTAX
  2397. C
  2398.       CALL TYPER(ATTYPE,MATV,ITYPE)
  2399.       IF(ITYPE.EQ.KZTEXT) GO TO 110
  2400.       NDIM = 1
  2401.       IF(MATV.EQ.KZMAT) NDIM = 2
  2402.       IF(LXWREC((4+NDIM),1).EQ.K4RPAR) GO TO 130
  2403.   110 CONTINUE
  2404.       WRITE (NOUT,120)
  2405.   120 FORMAT(45H -ERROR- BAD VEC(I) OR MAT(I,J) SPECIFICATION )
  2406.       GO TO 9999
  2407.   130 CONTINUE
  2408.       IROW = LXIREC(4)
  2409.       ICOL = LXIREC(5)
  2410.       IF(NDIM.EQ.1) ICOL = 1
  2411.       NEWL = 1
  2412.       IF(ITYPE.EQ.KZDOUB) NEWL = 2
  2413.       ID = 6 + NDIM
  2414. C
  2415. C  CHECK VALUE SYNTAX (ONLY ONE ITEM ALLOWED)
  2416. C
  2417.       JJ = ID + 1
  2418.       IF(EQKEYW(JJ,KWIN,2)) GO TO 135
  2419.       IF(EQKEYW(JJ,KWWHER,5)) GO TO 135
  2420.       GO TO 110
  2421.   135 CONTINUE
  2422.       CALL PARVAL(ID,NVAL,ATTYPE,NEWL,NROW,0,IERR)
  2423.       IF(IERR.NE.0) GO TO 9999
  2424.       IP = 0
  2425.       IF(ATTWDS.EQ.0) GO TO 400
  2426.       IF(NROW.EQ.0) NROW = ATTWDS
  2427.       IF(IROW.GT.NROW) GO TO 110
  2428.       IP = NROW*(ICOL-1) + IROW
  2429.       IF(ITYPE.EQ.KZDOUB) IP = 2*IP - 1
  2430.       IP = IP + ATTCOL - 1
  2431.       IF(MATV.NE.KZMAT) GO TO 400
  2432.       IF(IROW*ICOL.GT.ATTWDS) GO TO 110
  2433.       GO TO 400
  2434.   200 CONTINUE
  2435.       ID = 4
  2436.       CALL PARVAL(ID,NVAL,ATTYPE,NEWL,NROW,0,IERR)
  2437.       IF(IERR.NE.0) GO TO 9999
  2438.   400 CONTINUE
  2439. C
  2440. C  CHECK FOR RULES FOR THIS RELATION
  2441. C
  2442.       ANAME = ATTNAM
  2443.       RNAME = RELNAM
  2444.       BYPASS = .TRUE.
  2445.       IF(.NOT.RUCK) GO TO 460
  2446.       CALL CHKRUL(RNAME)
  2447.       I = LOCATT(ANAME,RNAME)
  2448.       CALL ATTGET(ISTAT)
  2449.       I = LOCREL(RNAME)
  2450.       CALL RELGET(ISTAT)
  2451.       IF(RMSTAT.LT.110) GO TO 450
  2452.       IF(RMSTAT.EQ.110) WRITE(NOUT,410)
  2453.       IF(RMSTAT.EQ.111) WRITE(NOUT,420)
  2454.   410 FORMAT(35H -ERROR- UNRECOGNIZED RULE RELATION)
  2455.   420 FORMAT(50H -ERROR- MORE THAN 10 RULES APPLY TO THIS RELATION)
  2456.       GO TO 9999
  2457.   450 CONTINUE
  2458.       IF(RUCK.AND.RULES) BYPASS = .FALSE.
  2459.       IF(BYPASS) GO TO 460
  2460. C
  2461. C  SAVE THE RULE WHERE CLAUSE
  2462. C
  2463.       RULWHR(1) = NBOO
  2464.       RULWHR(2) = BOO(1)
  2465.       RULWHR(3) = KATTP(1)
  2466.       RULWHR(4) = KATTL(1)
  2467.       RULWHR(5) = KATTY(1)
  2468.       RULWHR(6) = KOMTYP(1)
  2469.       RULWHR(7) = KOMPOS(1)
  2470.       RULWHR(8) = KOMLEN(1)
  2471.       RULWHR(9) = KOMPOT(1)
  2472.       RULWHR(10) = KSTRT
  2473.       RULWHR(11) = MAXTU
  2474.       RULWHR(12) = LIMTU
  2475.       RULWHR(13) = WHRVAL(1)
  2476.       RULWHR(14) = WHRLEN(1)
  2477.   460 CONTINUE
  2478. C
  2479. C  PROCESS THE WHERE CLAUSE.
  2480. C
  2481.       CALL WHERE(J)
  2482.       IF(RMSTAT.NE.0) GO TO 9999
  2483.       IF(BYPASS) GO TO 480
  2484. C
  2485. C  USE THE SORT BUFFER TO SAVE THE CHANGE WHERE CLAUSE
  2486. C
  2487.       CALL BLKMOV(SORBUF,NBOO,484)
  2488.   480 CONTINUE
  2489. C
  2490. C  RESTORE THE TUPLEA POINTERS.
  2491. C
  2492.       J = LOCATT(ANAME,RNAME)
  2493.       CALL ATTGET(ISTAT)
  2494. C
  2495. C  SEQUENCE THROUGH THE DATA.
  2496. C
  2497.   500 CONTINUE
  2498.       IF(BYPASS) GO TO 510
  2499. C
  2500. C  RESTORE THE CHANGE WHERE CLAUSE
  2501. C
  2502.       CALL BLKMOV(NBOO,SORBUF,484)
  2503.       CALL RMLOOK(MAT,1,0,LENGTH)
  2504.       IF(RMSTAT.NE.0) GO TO 9999
  2505. C
  2506. C  RESTORE THE RULE WHERE CLAUSE
  2507. C
  2508.       NBOO = RULWHR(1)
  2509.       BOO(1) = RULWHR(2)
  2510.       KATTP(1) = RULWHR(3)
  2511.       KATTL(1) = RULWHR(4)
  2512.       KATTY(1) = RULWHR(5)
  2513.       KOMTYP(1) = RULWHR(6)
  2514.       KOMPOS(1) = RULWHR(7)
  2515.       KOMLEN(1) = RULWHR(8)
  2516.       KOMPOT(1) = RULWHR(9)
  2517.       KSTRT = RULWHR(10)
  2518.       MAXTU = RULWHR(11)
  2519.       LIMTU = RULWHR(12)
  2520.       WHRVAL(1) = RULWHR(13)
  2521.       WHRLEN(1) = RULWHR(14)
  2522.       GO TO 520
  2523. C
  2524. C  NO RULES
  2525. C
  2526.   510 CONTINUE
  2527.       CALL RMLOOK(MAT,1,0,LENGTH)
  2528.       IF(RMSTAT.NE.0) GO TO 9999
  2529.   520 CONTINUE
  2530.       IF(IVAL.GT.NTUPLE) GO TO 9999
  2531.       START = ATTKEY
  2532.       COLUMN = ATTCOL
  2533. C
  2534. C  CHANGE IT.
  2535. C
  2536.       IF(SINGLE) GO TO 5000
  2537.       IF(ATTWDS.EQ.0) GO TO 2000
  2538. C
  2539. C  CHANGE IS TO A FIXED LENGTH ATTRIBUTE.
  2540. C
  2541.       NEWVAL = 1
  2542.       IF(MAT(COLUMN).EQ.NVAL(1)) NEWVAL = 0
  2543.       IVOLD = MAT(COLUMN)
  2544.       K = COLUMN - 1
  2545.       DO 600 L=1,ATTWDS
  2546.       MAT(K+L) = NVAL(L)
  2547.   600 CONTINUE
  2548.   700 CONTINUE
  2549.       IF(BYPASS) GO TO 800
  2550. C
  2551. C  SEE IF THE APPLICABLE RULES ARE SATISFIED
  2552. C
  2553.       CALL CHKTUP(MAT,ISTAT)
  2554. C
  2555. C  RESTORE THE TUPLEA POINTERS
  2556. C
  2557.       IF(ISTAT.GT.0) GO TO 710
  2558.       I = LOCATT(ANAME,RNAME)
  2559.       CALL ATTGET(XSTAT)
  2560.       IF(ISTAT.EQ.0) GO TO 800
  2561.       GO TO 720
  2562.   710 CONTINUE
  2563.       WRITE(NOUT,9005) IVAL
  2564.       ISNOUT = NOUTR
  2565.       NOUTR = NOUT
  2566.       CALL PRULE(ISTAT)
  2567.       NOUTR = ISNOUT
  2568.       GO TO 500
  2569.   720 CONTINUE
  2570.       ISTAT = -ISTAT
  2571.       WRITE(NOUT,9006) ISTAT
  2572.       GO TO 500
  2573.   800 CONTINUE
  2574.       IF((START.EQ.0).OR.(NEWVAL.EQ.0)) GO TO 1000
  2575.       CALL BTREP(IVOLD,0,CID,ATTYPE)
  2576.       IF(MAT(COLUMN).EQ.NULL) GO TO 1000
  2577.       ATTKEY = START
  2578.       CALL BTADD(MAT(COLUMN),CID,ATTYPE)
  2579.       IF(ATTKEY.EQ.START) GO TO 1000
  2580.       ATTKEY = START
  2581.       CALL ATTPUT(ISTAT)
  2582.  1000 CONTINUE
  2583.       CALL PUTDAT(1,CID,MAT,LENGTH)
  2584.       NC = NC + 1
  2585.       GO TO 500
  2586. C
  2587. C  CHANGE IS TO A VARIABLE LENGTH ATTRIBUTE.
  2588. C
  2589.  2000 CONTINUE
  2590.       NEWVAL = 1
  2591. C
  2592. C  FIND THE ACTUAL COLUMN FOR VARIABLE LENGTH STUFF.
  2593. C
  2594.       COLUMN = MAT(ATTCOL)
  2595.       KURLEN = MAT(COLUMN)
  2596.       IF(KURLEN.LT.NEWL) GO TO 3000
  2597.       COLUMN = COLUMN + 2
  2598.       IF(MAT(COLUMN).EQ.NVAL(1)) NEWVAL = 0
  2599.       IVOLD = MAT(COLUMN)
  2600.       K = COLUMN - 1
  2601.       DO 2200 L=1,NEWL
  2602.       MAT(K+L) = NVAL(L)
  2603.  2200 CONTINUE
  2604. C
  2605. C  RESET THE VARIABLE LENGTH STUFF
  2606. C
  2607.       MAT(COLUMN-2) = NEWL
  2608.       MAT(COLUMN-1) = NROW
  2609.       IF(BYPASS) GO TO 2300
  2610. C
  2611. C  SEE IF THE APPLICABLE RULES ARE SATISFIED
  2612. C
  2613.       CALL CHKTUP(MAT,ISTAT)
  2614. C
  2615. C  RESTORE THE TUPLEA POINTERS
  2616. C
  2617.       IF(ISTAT.GT.0) GO TO 2210
  2618.       I = LOCATT(ANAME,RNAME)
  2619.       CALL ATTGET(XSTAT)
  2620.       IF(ISTAT.EQ.0) GO TO 2300
  2621.       GO TO 2220
  2622.  2210 CONTINUE
  2623.       WRITE(NOUT,9005) IVAL
  2624.       ISNOUT = NOUTR
  2625.       NOUTR = NOUT
  2626.       CALL PRULE(ISTAT)
  2627.       NOUTR = ISNOUT
  2628.       GO TO 500
  2629.  2220 CONTINUE
  2630.       ISTAT = -ISTAT
  2631.       WRITE(NOUT,9006) ISTAT
  2632.       GO TO 500
  2633.  2300 CONTINUE
  2634.       IF(START.EQ.0) GO TO 2600
  2635.       IF(NEWVAL.EQ.0) GO TO 2600
  2636.       CALL BTREP(IVOLD,0,CID,ATTYPE)
  2637.       IF(MAT(COLUMN).EQ.NULL) GO TO 2600
  2638.       ATTKEY = START
  2639.       CALL BTADD(MAT(COLUMN),CID,ATTYPE)
  2640.       IF(ATTKEY.EQ.START) GO TO 2600
  2641.       ATTKEY = START
  2642.       CALL ATTPUT(ISTAT)
  2643.  2600 CONTINUE
  2644.       CALL PUTDAT(1,CID,MAT,LENGTH)
  2645.       NC = NC + 1
  2646.       GO TO 500
  2647. C
  2648. C  CHANGE IS TO A VARIABLE LENGTH ATTRIBUTE WITH THE NEW VALUE
  2649. C  BIGGER THAN THE OLD VALUE.
  2650. C
  2651.  3000 CONTINUE
  2652.       EXTRA = NEWL - KURLEN
  2653.       IF((LENGTH+EXTRA).GT.MAXCOL) GO TO 8100
  2654. C
  2655. C  NOW FIX UP THE MODIFIED TUPLE.
  2656. C
  2657.       I = LOCATT(ANAME,RNAME)
  2658.       CALL ATTGET(ISTAT)
  2659.       COLUMN = MAT(ATTCOL)
  2660.       IVOLD = MAT(COLUMN+2)
  2661. C
  2662. C  FIGURE OUT HOW TO SHIFT THE VARIABLE LENGTH STUFF AROUND.
  2663. C
  2664.       ISHIFT = KURLEN + 2
  2665.       MOVE = LENGTH - ISHIFT - COLUMN + 1
  2666.       IF(MOVE.GT.0)
  2667.      X CALL BLKMOV(MAT(COLUMN),MAT(COLUMN+ISHIFT),MOVE)
  2668. C
  2669. C  NOW REBUILD ALL VARIABLE LENGTH POINTERS.
  2670. C
  2671.       I = LOCATT(BLANK,NAME)
  2672.       DO 3500 I=1,NATT
  2673.       CALL ATTGET(ISTAT)
  2674.       IF(ISTAT.NE.0) GO TO 3500
  2675.       IF(ATTWDS.NE.0) GO TO 3500
  2676.       KURCOL = ATTCOL
  2677.       IF(MAT(KURCOL).LT.COLUMN) GO TO 3500
  2678. C
  2679. C  CHANGE THE POINTER TO POINT TO THE NEW LOCATION OF THE DATA.
  2680. C
  2681.       NEWVAL = 0
  2682.       MAT(KURCOL) = MAT(KURCOL) - ISHIFT
  2683.  3500 CONTINUE
  2684. C
  2685. C  PUT THE NEW VALUE IN ITS PLACE.
  2686. C
  2687.       I = LOCATT(ANAME,RNAME)
  2688.       CALL ATTGET(ISTAT)
  2689.       MAT(ATTCOL) = LENGTH - ISHIFT + 1
  2690.       COLUMN = MAT(ATTCOL)
  2691.       MAT(COLUMN) = NEWL
  2692.       MAT(COLUMN+1) = NROW
  2693.       COLUMN = COLUMN + 2
  2694.       K = COLUMN - 1
  2695.       DO 3600 L=1,NEWL
  2696.       MAT(K+L) = NVAL(L)
  2697.  3600 CONTINUE
  2698.       IF(BYPASS) GO TO 3900
  2699. C
  2700. C  SEE IF THE APPLICABLE RULES ARE SATISFIED
  2701. C
  2702.       CALL CHKTUP(MAT,ISTAT)
  2703. C
  2704. C  RESTORE THE TUPLEA POINTERS
  2705. C
  2706.       IF(ISTAT.GT.0) GO TO 3880
  2707.       I = LOCATT(ANAME,RNAME)
  2708.       CALL ATTGET(XSTAT)
  2709.       IF(ISTAT.EQ.0) GO TO 3900
  2710.       GO TO 3890
  2711.  3880 CONTINUE
  2712.       WRITE(NOUT,9005) IVAL
  2713.       ISNOUT = NOUTR
  2714.       NOUTR = NOUT
  2715.       CALL PRULE(ISTAT)
  2716.       NOUTR = ISNOUT
  2717.       GO TO 500
  2718.  3890 CONTINUE
  2719.       ISTAT = -ISTAT
  2720.       WRITE(NOUT,9006) ISTAT
  2721.       GO TO 500
  2722.  3900 CONTINUE
  2723. C
  2724. C  OLD TUPLE MUST BE DELETED AND THE CHANGED ONE ADDED.
  2725. C
  2726.       CALL DELDAT(1,CID)
  2727. C
  2728. C  ADD THE NEW TUPLE.
  2729. C
  2730.       CALL ADDDAT(1,REND,MAT,LENGTH+EXTRA)
  2731. C
  2732. C  CHANGE THE POINTERS FOR ANY KEY ATTRIBUTES.
  2733. C
  2734.       I = LOCATT(BLANK,NAME)
  2735.       DO 3400 I=1,NATT
  2736.       CALL ATTGET(ISTAT)
  2737.       IF(ISTAT.NE.0) GO TO 3400
  2738.       IF(ATTKEY.EQ.0) GO TO 3400
  2739.       START = ATTKEY
  2740.  
  2741.       KSTART = ATTKEY
  2742.       COLUMN = ATTCOL
  2743.       IF(ATTWDS.NE.0) GO TO 3100
  2744.       COLUMN = MAT(COLUMN) + 2
  2745.  3100 CONTINUE
  2746.       IF(NE(ATTNAM,ANAME)) GO TO 3200
  2747.       CALL BTREP(IVOLD,0,CID,ATTYPE)
  2748.       GO TO 3400
  2749.  3200 CONTINUE
  2750.       IF(MAT(COLUMN).NE.NULL) GO TO 3300
  2751.       CALL BTREP(MAT(COLUMN),0,CID,ATTYPE)
  2752.       GO TO 3400
  2753.  3300 CONTINUE
  2754.       CALL BTREP(MAT(COLUMN),REND,CID,ATTYPE)
  2755.       IF(START.EQ.KSTART) GO TO 3400
  2756.       ATTKEY = START
  2757.       CALL ATTPUT(ISTAT)
  2758.  3400 CONTINUE
  2759. C
  2760. C  UPDATE THE KEY VALUE FOR THE NEW ATTRIBUTE VALUE
  2761. C
  2762.       I = LOCATT(ANAME,RNAME)
  2763.       CALL ATTGET(ISTAT)
  2764.       START = ATTKEY
  2765.       IF(START.EQ.0) GO TO 4000
  2766.       IF(MAT(COLUMN).EQ.NULL) GO TO 4000
  2767.       CALL BTADD(MAT(COLUMN),REND,ATTYPE)
  2768.       IF(ATTKEY.EQ.START) GO TO 4000
  2769.       ATTKEY = START
  2770.       CALL ATTPUT(ISTAT)
  2771.  4000 CONTINUE
  2772.       IF(CID.EQ.RSTART) RSTART = NID
  2773. C
  2774. C     ACTUALLY ADD THE TUPLE
  2775. C
  2776.       CALL PUTDAT(1,REND,MAT,LENGTH+EXTRA)
  2777.       NC = NC + 1
  2778.       CALL RELPUT
  2779.       GO TO 500
  2780.  5000 CONTINUE
  2781. C
  2782. C     CHANGE A SINGLE WORD
  2783. C
  2784.       IVOLD = MAT(ATTCOL)
  2785.       IF(ATTWDS.NE.0) GO TO 5100
  2786.       IP = MAT(ATTCOL)
  2787.       NW = MAT(IP)
  2788.       NR = MAT(IP+1)
  2789.       COLUMN = IP + 2
  2790.       IVOLD = MAT(COLUMN)
  2791.       IF(NR.EQ.0) NR = NW
  2792.       IF(IROW.LE.NR) GO TO 5050
  2793.       IF(IROW*ICOL.LE.NW) GO TO 5050
  2794. C
  2795. C     OUT OF RANGE
  2796. C
  2797.       NOPE = NOPE + 1
  2798.       GO TO 500
  2799.  5050 CONTINUE
  2800.       IJ = NR*(ICOL-1) + IROW
  2801.       IF(ITYPE.EQ.KZDOUB) IJ = 2*IJ - 1
  2802.       IP = IP + IJ + 1
  2803.  5100 CONTINUE
  2804.       NEWVAL = 1
  2805.       IF(MAT(IP).EQ.NVAL(1)) NEWVAL = 0
  2806.       MAT(IP) = NVAL(1)
  2807.       IF(ITYPE.EQ.KZDOUB) MAT(IP+1) = NVAL(2)
  2808.       IF(IROW.NE.1) NEWVAL = 0
  2809.       IF(ICOL.NE.1) NEWVAL = 0
  2810.       GO TO 700
  2811. C
  2812. C  TUPLE LENGTH EXCCEDS MAXCOL
  2813. C
  2814.  8100 CONTINUE
  2815.       WRITE(NOUT,8110) MAXCOL
  2816.  8110 FORMAT(36H -ERROR- RELATION ROW LENGTH EXCEEDS,I5)
  2817.       GO TO 9999
  2818. C
  2819. C  DONE
  2820. C
  2821.  9999 CONTINUE
  2822.       WRITE(NOUT,9003) NC,NAME
  2823.  9003 FORMAT(2X,I6,26H ROWS CHANGED IN RELATION ,A8)
  2824.       IF(NOPE.EQ.0) RETURN
  2825.       WRITE(NOUT,9004)NOPE
  2826.  9004 FORMAT(11H -WARNING- ,I5,33H ROWS HAD INCOMPATIBLE DIMENSIONS )
  2827.       RETURN
  2828.  9005 FORMAT(12H -ERROR- ROW,I4,22H FAILS TO SATISFY THE ,
  2829.      X       14HFOLLOWING RULE)
  2830.  9006 FORMAT(32H -ERROR- UNABLE TO PROCESS RULE ,I3)
  2831.       END
  2832.       SUBROUTINE CHKATT(JUNK,NUMELE,ERROR)
  2833.         Include TEXT.BLK
  2834. C
  2835. C  THIS ROUTINE EDITS THE ATTRIBUTE LIST ON THE RELATION CARDS
  2836. C  AND CREATES THE NEW RELATIONS BASED ON THE CARDS.  THE EXISTENCE
  2837. C  OF THESE NEW RELATIONS IS RECORDED IN RIMS INTERNAL TABLES.
  2838. C
  2839. C  PARAMETERS:
  2840. C         JUNK----SCRATCH ARRAY WITH NEW ATTRIBUTE NAMES
  2841. C         NUMELE--THE NUMBER OF ATTRIBUTES IN JUNK
  2842. C         ERROR---COUNT OF THE ERRORS ENCOUNTERED
  2843. C
  2844.         Include TUPLEA.BLK
  2845.         Include TUPLER.BLK
  2846.         Include FILES.BLK
  2847.         Include MISC.BLK
  2848. C
  2849.       INTEGER ERROR
  2850.       LOGICAL EQ
  2851.       INTEGER IFLAG
  2852.       INTEGER CSTART
  2853.       INTEGER JUNK(5,*)
  2854.         Include DCLAR1.BLK
  2855. C
  2856.       NCOLS = 0
  2857.       IFLAG = 0
  2858. C
  2859. C  SEARCH THE LIST
  2860. C
  2861.       ITEMS = LXITEM(IDUMMY)
  2862.       RNAME = BLANK
  2863.       DO 600 I=3,ITEMS
  2864.       ANAME = BLANK
  2865.       CALL LXSREC(I,1,8,ANAME,1)
  2866. C
  2867. C  LOOK FOR THIS ATTRIBUTE AMONG EXISTING ATTRIBUTES.
  2868. C
  2869.       J = LOCATT(ANAME,RNAME)
  2870.       IF(J.NE.0) GO TO 100
  2871.       CALL ATTGET(IDUMMY)
  2872.       NCHAR = ATTCHA
  2873.       NWORDS = ATTWDS
  2874.       GO TO 500
  2875. C
  2876. C  LOOK FOR THIS ATTRIBUTE AMONG NEW ATTRIBUTES.
  2877. C
  2878.   100 CONTINUE
  2879.       IF(NUMELE.EQ.0) GO TO 300
  2880.       DO 200 J=1,NUMELE
  2881.       IF(EQ(JUNK(1,J),ANAME)) GO TO 400
  2882.   200 CONTINUE
  2883. C
  2884. C  CANNOT FIND THIS ATTRIBUTE.
  2885. C
  2886.   300 CONTINUE
  2887.       WRITE(NOUT,9000) ANAME
  2888.  9000 FORMAT(9H -ERROR- ,A8,26H IS AN UNDEFINED ATTRIBUTE )
  2889.       ERROR = ERROR + 1
  2890.       IFLAG = 1
  2891.       GO TO 600
  2892.   400 CONTINUE
  2893.       CALL ITOH(NCHAR,NWORDS,JUNK(4,J))
  2894.   500 CONTINUE
  2895. C
  2896. C  THE NUMBER OF WORDS NEEDED DEPEND ON THE ATTRIBUTE TYPE.
  2897. C
  2898.       IF(NWORDS.EQ.0) NWORDS = 1
  2899.       NCOLS = NCOLS + NWORDS
  2900.   600 CONTINUE
  2901.       IF(IFLAG.EQ.1) GO TO 999
  2902.       IF(NCOLS.LE.MAXCOL) GO TO 700
  2903.       WRITE(NOUT,9001) MAXCOL
  2904.  9001 FORMAT(36H -ERROR- RELATION ROW LENGTH EXCEEDS,I5)
  2905.       ERROR = ERROR + 1
  2906.       GO TO 999
  2907.   700 CONTINUE
  2908. C
  2909. C  LOAD THIS RELATION USING TUPLER AND TUPLEA.
  2910. C
  2911.       RNAME = BLANK
  2912.       CALL LXSREC(1,1,8,RNAME,1)
  2913.       NATT = ITEMS - 2
  2914.       CALL ATTNEW(RNAME,NATT)
  2915. C
  2916. C  SET UP THE NEW TUPLER.
  2917. C
  2918.       NAME = RNAME
  2919.       CALL RMDATE(RDATE)
  2920.       NCOL = NCOLS
  2921.       NTUPLE = 0
  2922.       RSTART = 0
  2923.       REND = 0
  2924.       RPW = NONE
  2925.       MPW = NONE
  2926.       CALL RELADD
  2927. C
  2928. C  NOW ADD TO THE ATTRIBUTE RELATION VIA TUPLEA.
  2929. C
  2930.       CSTART = 1
  2931.       DO 1600 I=3,ITEMS
  2932.       ANAME = BLANK
  2933.       CALL LXSREC(I,1,8,ANAME,1)
  2934. C
  2935. C  LOOK FOR THIS ATTRIBUTE AMONG EXISTING ATTRIBUTES.
  2936. C
  2937.       RNAME = BLANK
  2938.       J = LOCATT(ANAME,RNAME)
  2939.       IF(J.NE.0) GO TO 1100
  2940.       CALL ATTGET(IDUMMY)
  2941.       RELNAM = NAME
  2942.       ATTCOL = CSTART
  2943.       GO TO 1500
  2944. C
  2945. C  LOOK FOR THIS ATTRIBUTE AMONG NEW ATTRIBUTES.
  2946. C
  2947.  1100 CONTINUE
  2948.       IF(NUMELE.EQ.0) GO TO 1500
  2949.       DO 1200 J=1,NUMELE
  2950.       IF(EQ(JUNK(1,J),ANAME)) GO TO 1400
  2951.  1200 CONTINUE
  2952.  1400 CONTINUE
  2953.       ATTNAM = ANAME
  2954.       RELNAM = NAME
  2955.       ATTCOL = CSTART
  2956.       ATTLEN = JUNK(4,J)
  2957.       ATTYPE = JUNK(3,J)
  2958.       ATTKEY = JUNK(5,J)
  2959.  1500 CONTINUE
  2960.       CALL ITOH(NCHAR,NWORDS,ATTLEN)
  2961.       IF(NWORDS.EQ.0) NWORDS = 1
  2962.       CSTART = CSTART + NWORDS
  2963.       IF(ATTKEY.NE.0) CALL BTINIT(ATTKEY)
  2964.       CALL ATTADD
  2965.  1600 CONTINUE
  2966. C
  2967. C  DONE
  2968. C
  2969.   999 RETURN
  2970.       END
  2971.       SUBROUTINE CHKREL (PERM,WORD1,ISTAT,NAMOWN)
  2972.         Include TEXT.BLK
  2973. C
  2974. C  PURPOSE:  CHECKS PERMISSION TO SEE IF USER CAN UNLOAD THIS
  2975. C            RELATION.  PERM SET TO TRUE IF USER CAN.
  2976. C
  2977. C  INPUTS:
  2978. C            WORD1-------COMMAND SPECIFIED (ALL,DATA,OR SCHEMA)
  2979. C          ISTAT------------WAS THE RELATION GET SUCCESSFUL?
  2980. C          NAMOWN-----------USERID
  2981. C
  2982. C  OUTPUT:
  2983. C            PERM-------TRUE IF USER HAS PERMISSION TO UNLOAD
  2984. C                       FALSE OTHERWISE
  2985. C
  2986.         Include CONST4.BLK
  2987.         Include CONST8.BLK
  2988.         Include DCLAR2.BLK
  2989.         Include DCLAR6.BLK
  2990.         Include TUPLER.BLK
  2991.         Include FLAGS.BLK
  2992.       INTEGER ISTAT
  2993.       LOGICAL PERM
  2994.       PERM = .TRUE.
  2995.       CALL RELGET (ISTAT)
  2996.       IF (ISTAT .NE. 0) GO TO 10
  2997. C
  2998. C  CHECK FOR RULES RELATION
  2999. C
  3000.       IF((NAME.EQ.K8RRC).OR.(NAME.EQ.K8RDT)) GO TO 10
  3001. C
  3002. C  CHECK FOR OWNER
  3003. C
  3004.       IF(OWNER.EQ.NAMOWN) GO TO 20
  3005. C
  3006. C  CHECK FOR MODIFY PASSWORD
  3007. C
  3008.       IF ((MPW .EQ. K4NONE) .OR. (MPW .EQ. NAMOWN)) GO TO 20
  3009.    10 CONTINUE
  3010.       PERM = .FALSE.
  3011.    20 CONTINUE
  3012.       RETURN
  3013.       END
  3014.       SUBROUTINE CHKRUL(RNAME)
  3015.         Include TEXT.BLK
  3016. C
  3017. C  PURPOSE: CHECK IF RULES APPLY TO THE CURRENT RELATION
  3018. C
  3019. C  PARAMETERS:  RNAME--RELATION NAME TO CHECK
  3020. C
  3021.         Include CONST4.BLK
  3022.         Include CONST8.BLK
  3023.         Include RIMCOM.BLK
  3024.         Include RULCOM.BLK
  3025.         Include TUPLEA.BLK
  3026.         Include MISC.BLK
  3027.         Include RIMPTR.BLK
  3028.         Include BUFFER.BLK
  3029.         Include WHCOM.BLK
  3030.         Include DCLAR1.BLK
  3031.       RULES = .TRUE.
  3032. C
  3033. C  LOCATE THE RULES RELATION
  3034. C
  3035.       I = LOCREL(RIMRRC)
  3036.       IF(I.EQ.0) GO TO 100
  3037.       RULES = .FALSE.
  3038.       GO TO 999
  3039. C
  3040. C  SET UP A WHERE CLAUSE FOR THE RULES RELATION
  3041. C
  3042.   100 CONTINUE
  3043.       NBOO = 0
  3044.       I = LOCATT(K8NAM,RIMRRC)
  3045.       IF(I.NE.0) GO TO 200
  3046.       CALL ATTGET(I)
  3047.       IF(I.EQ.0) GO TO 300
  3048. C
  3049. C  BAD RULES RELATION
  3050. C
  3051.   200 CONTINUE
  3052.       RULES = .FALSE.
  3053.       RMSTAT = 110
  3054.       GO TO 999
  3055. C
  3056. C  LOAD WHCOM
  3057. C
  3058.   300 CONTINUE
  3059.       NBOO = 1
  3060.       BOO(1) = K4AND
  3061.       KATTP(1) = ATTCOL
  3062.       KATTL(1) = ATTLEN
  3063.       KATTY(1) = ATTYPE
  3064.       KOMTYP(1) = 2
  3065.       KOMPOS(1) = 1
  3066.       KOMLEN(1) = 1
  3067.       KOMPOT(1) = 1
  3068.       KSTRT = 0
  3069.       MAXTU = ALL9S
  3070.       LIMTU = ALL9S
  3071.       WHRVAL(1) = IBLANK
  3072.       CALL STRMOV(RNAME,1,8,WHRVAL,1)
  3073.       WHRLEN(1) = ATTLEN
  3074.       NS = 0
  3075. C
  3076. C  RETRIEVE THE RULE NUMBERS THAT APPLY AND STORE IN RULNUM
  3077. C
  3078.       RULCNT = 0
  3079.   400 CONTINUE
  3080.       CALL RMLOOK(IP,2,1,LEN)
  3081.       IF(RMSTAT.NE.0) GO TO 500
  3082.       RULCNT = RULCNT + 1
  3083.       IF(RULCNT.LE.10) GO TO 450
  3084. C
  3085. C  TOO MANY RULES
  3086. C
  3087.       RULES = .FALSE.
  3088.       RMSTAT = 111
  3089.       GO TO 999
  3090.   450 CONTINUE
  3091.       RULNUM(RULCNT) = BUFFER(IP+2)
  3092.       GO TO 400
  3093. C
  3094. C IF RULES APPLY SET UP DATA POINTERS AND WHERE CLAUSE FOR RULE NUMBERS
  3095. C
  3096.   500 CONTINUE
  3097.       IF(RULCNT.NE.0) GO TO 600
  3098.       RULES = .FALSE.
  3099.       GO TO 999
  3100. C
  3101. C  SET RELATION POINTERS
  3102. C
  3103.   600 CONTINUE
  3104.       I = LOCREL(RIMRDT)
  3105.       IF(I.EQ.0) GO TO 700
  3106.       RULES = .FALSE.
  3107.       RMSTAT = 110
  3108.       GO TO 999
  3109. C
  3110. C  STORE THE RELATION POINTERS IN RULPTR
  3111. C
  3112.   700 CONTINUE
  3113.       CALL BLKMOV(RULPTR,IVAL,6)
  3114. C
  3115. C  LOAD WHCOM
  3116. C
  3117.       I = LOCATT(K8NUM,RIMRDT)
  3118.       IF(I.NE.0) GO TO 200
  3119.       CALL ATTGET(I)
  3120.       IF(I.NE.0) GO TO 200
  3121.       KATTP(1) = ATTCOL
  3122.       KATTL(1) = ATTLEN
  3123.       KATTY(1) = ATTYPE
  3124.       WHRVAL(1) = 0
  3125.       WHRLEN(1) = ATTLEN
  3126. C
  3127.   999 CONTINUE
  3128.       RETURN
  3129.       END
  3130.       SUBROUTINE CHKTUP(TUPLE,ISTAT)
  3131.         Include TEXT.BLK
  3132. C
  3133. C  PURPOSE:  THIS ROUTINE SEES IF A TUPLE SATISFIES THE RULE.
  3134. C
  3135. C  PARAMETERS:
  3136. C         TUPLE---DATA MATRIX TUPLE
  3137. C         RNAME---RELATION NAME
  3138. C         ISTAT---STATUS FLAG  0 FOR OK, 1 FOR NOT OK, -1 FOR TILT
  3139.         Include RMATTS.BLK
  3140.         Include CONST4.BLK
  3141.         Include RIMCOM.BLK
  3142.         Include MISC.BLK
  3143.         Include RIMPTR.BLK
  3144.         Include TUPLEA.BLK
  3145.         Include TUPLER.BLK
  3146.         Include RULCOM.BLK
  3147.         Include WHCOM.BLK
  3148.         Include RELTBL.BLK
  3149. C
  3150.         Include FLAGS.BLK
  3151.         Include DCLAR1.BLK
  3152. C  DIMENSION STATEMENTS.
  3153. C
  3154.       LOGICAL OK,QUAL
  3155.       INTEGER TUPLE(1)
  3156.       INTEGER ARRAY(24)
  3157.       INTEGER KOM(6)
  3158.       INTEGER SAVTUR(13)
  3159.       INTEGER SAVTUP(6)
  3160.       INTEGER SAVSCR(25)
  3161.       EQUIVALENCE (KOM(1),K4KOM(1))
  3162. C
  3163. C     NO TOLERANCE FOR RULES
  3164. C
  3165.       TOLSAV = TOL
  3166.       TOL = 0.
  3167. C
  3168. C  SAVE THE DATA FOR THE RELATION BEING LOADED
  3169. C
  3170.       RNAME = NAME
  3171.       MWDS = 5 + ((8-1)/CHPWD + 1)*4
  3172.       CALL BLKMOV(SAVTUR,NAME,MWDS)
  3173.       CALL BLKMOV(SAVTUP,IVAL,6)
  3174. C
  3175. C  PROCESS THE RULES
  3176. C
  3177.       QUAL = .TRUE.
  3178.       DO 2000 K=1,RULCNT
  3179. C
  3180. C  RESTORE THE RULE RELATION POINTERS
  3181. C
  3182.       CALL BLKMOV(IVAL,RULPTR,6)
  3183.       WHRVAL(1) = RULNUM(K)
  3184. C
  3185. C  SET UP TO FIND THIS RULE.
  3186. C
  3187.   100 CONTINUE
  3188.       CALL RMLOOK(ARRAY,2,0,LEN)
  3189.       IF(RMSTAT.NE.0) GO TO 1000
  3190. C
  3191. C  GET THE ATTRIBUTE NAME.
  3192. C
  3193.       I = LOCATT(ARRAY(4),RNAME)
  3194.       IF(I.NE.0) GO TO 9997
  3195.       CALL ATTGET(JSTAT)
  3196.       IF(JSTAT.NE.0) GO TO 9997
  3197.       NATTP = ATTCOL
  3198.       IF(ATTWDS.NE.0) GO TO 200
  3199. C
  3200. C  VARIABLE LENGTH ATTRIBUTE.
  3201. C
  3202.       NATTP = TUPLE(NATTP)
  3203.       ATTWDS = TUPLE(NATTP)
  3204.       ATTCHA = 0
  3205.       IF(ATTYPE.EQ.KZTEXT) ATTCHA = TUPLE(NATTP+1)
  3206.       IF(ATTYPE.EQ.KZIMAT) ATTCHA = TUPLE(NATTP+1)
  3207.       IF(ATTYPE.EQ.KZRMAT) ATTCHA = TUPLE(NATTP+1)
  3208.       IF(ATTYPE.EQ.KZDMAT) ATTCHA = TUPLE(NATTP+1)
  3209.       NATTP = NATTP + 2
  3210.   200 CONTINUE
  3211.       ITYPE = ATTYPE
  3212. C
  3213. C  GET THE BOOLEAN OPERATOR.
  3214. C
  3215.       NBOOT = LOCBOO(ARRAY(8))
  3216.       IF(NBOOT.GT.10) GO TO 300
  3217. C
  3218. C  VALUE COMPARISON.
  3219. C
  3220.       OK = .FALSE.
  3221.       CALL KOMPXX(TUPLE(NATTP),ARRAY(15),ATTWDS,NBOOT,OK,ITYPE)
  3222.       GO TO 600
  3223. C
  3224. C  ATTRIBUTE COMPARISON.
  3225. C  SAVE THE CURRENT RULE POINTERS AND WHERE STUFF
  3226. C
  3227.   300 CONTINUE
  3228.       CALL BLKMOV(SAVSCR,IVAL,6)
  3229.       SAVSCR(7) = NBOO
  3230.       SAVSCR(8) = BOO(1)
  3231.       SAVSCR(9) = KATTP(1)
  3232.       SAVSCR(10) = KATTL(1)
  3233.       SAVSCR(11) = KATTY(1)
  3234.       SAVSCR(12) = KOMTYP(1)
  3235.       SAVSCR(13) = KOMPOS(1)
  3236.       SAVSCR(14) = KOMLEN(1)
  3237.       SAVSCR(15) = KOMPOT(1)
  3238.       SAVSCR(16) = KSTRT
  3239.       SAVSCR(17) = MAXTU
  3240.       SAVSCR(18) = LIMTU
  3241.       SAVSCR(19) = WHRVAL(1)
  3242.       SAVSCR(20) = WHRVAL(2)
  3243.       SAVSCR(21) = WHRLEN(1)
  3244.       CALL BLKMOV(SAVSCR(22),LRROW,4)
  3245. C
  3246. C  PREPARE TO CALL RMLOOK.
  3247. C
  3248.       NBOOT = NBOOT - 11
  3249.       NP = NATTP - 1
  3250.       DO 400 I=1,ATTWDS
  3251.       WHRVAL(I) = TUPLE(NP+I)
  3252.   400 CONTINUE
  3253.       CALL HTOI(ATTCHA,ATTWDS,WHRLEN(1))
  3254.       RMSTAT = 0
  3255.       I = LOCREL(ARRAY(13))
  3256.       IF(I.NE.0) GO TO 500
  3257. C
  3258. C  SET UP A WHERE CLAUSE FOR THE ATTRIBUTE VALUE
  3259. C
  3260.       NBOO = 0
  3261.       I = LOCATT(ARRAY(11),ARRAY(13))
  3262.       IF(I.NE.0) GO TO 500
  3263.       CALL ATTGET(I)
  3264.       IF(I.NE.0) GO TO 500
  3265.       NBOO = 1
  3266.       BOO(1) = K4AND
  3267.       KATTP(1) = ATTCOL
  3268.       KATTL(1) = ATTLEN
  3269.       KATTY(1) = ATTYPE
  3270.       KOMTYP(1) = LOCBOO(KOM(NBOOT))
  3271.       KOMPOS(1) = 1
  3272.       KOMLEN(1) = 1
  3273.       KOMPOT(1) = 1
  3274.       CALL RMLOOK(NP,1,1,LEN)
  3275.   500 CONTINUE
  3276.       OK = .FALSE.
  3277.       IF(RMSTAT.EQ.0) OK = .TRUE.
  3278.       IF(NBOOT.NE.1) OK = .NOT.OK
  3279. C
  3280. C  RESTORE THE POINTERS AND THE WHERE CLAUSE
  3281. C
  3282.       CALL BLKMOV(IVAL,SAVSCR,6)
  3283.       NBOO = SAVSCR(7)
  3284.       BOO(1) = SAVSCR(8)
  3285.       KATTP(1) = SAVSCR(9)
  3286.       KATTL(1) = SAVSCR(10)
  3287.       KATTY(1) = SAVSCR(11)
  3288.       KOMTYP(1) = SAVSCR(12)
  3289.       KOMPOS(1) = SAVSCR(13)
  3290.       KOMLEN(1) = SAVSCR(14)
  3291.       KOMPOT(1) = SAVSCR(15)
  3292.       KSTRT = SAVSCR(16)
  3293.       MAXTU = SAVSCR(17)
  3294.       LIMTU = SAVSCR(18)
  3295.       WHRVAL(1) = SAVSCR(19)
  3296.       WHRVAL(2) = SAVSCR(20)
  3297.       WHRLEN(1) = SAVSCR(21)
  3298.       CALL BLKMOV(LRROW,SAVSCR(22),4)
  3299.   600 CONTINUE
  3300.       IF(ARRAY(2).EQ.K4AND) QUAL = QUAL.AND.OK
  3301.       IF(ARRAY(2).EQ.K4OR) QUAL = QUAL.OR.OK
  3302. C
  3303. C  GO GET THE NEXT CONDITION IN THIS RULE.
  3304. C
  3305.       GO TO 100
  3306. C
  3307. C  DONE WITH A RULE.
  3308. C
  3309.  1000 CONTINUE
  3310.       ISTAT = 1
  3311.       IF(QUAL) ISTAT = 0
  3312.       IF(ISTAT.NE.0) GO TO 9998
  3313.  2000 CONTINUE
  3314.       GO TO 9999
  3315. C
  3316. C  TUPLE FAILS TO SATISFY RULE
  3317. C
  3318.  9998 CONTINUE
  3319.       ISTAT = RULNUM(K)
  3320.       GO TO 9999
  3321. C
  3322. C  UNABLE TO PROCESS RULES
  3323. C
  3324.  9997 CONTINUE
  3325.       ISTAT = -RULNUM(K)
  3326.  9999 CONTINUE
  3327. C
  3328. C  RESTORE THE RELATION DATA
  3329. C
  3330.       CALL BLKMOV(NAME,SAVTUR,MWDS)
  3331.       I = LOCREL(NAME)
  3332.       LRROW = LRROW + 1
  3333.       CALL BLKMOV(IVAL,SAVTUP,6)
  3334.       TOL = TOLSAV
  3335.       RETURN
  3336.       END
  3337.       SUBROUTINE CMPUTE
  3338.         Include TEXT.BLK
  3339. C
  3340. C  PURPOSE:    PROCESS COMPUTE COMMANDS
  3341. C
  3342. C
  3343.         Include RMATTS.BLK
  3344.         Include RMKEYW.BLK
  3345.         Include CONST4.BLK
  3346.         Include FILES.BLK
  3347.         Include MISC.BLK
  3348.         Include TUPLEA.BLK
  3349.         Include TUPLER.BLK
  3350.         Include RIMCOM.BLK
  3351.         Include BUFFER.BLK
  3352. C  DATA AND DIMENSION:
  3353.       INTEGER FTYPE
  3354.       INTEGER KVAL
  3355.       REAL RVAL
  3356.       EQUIVALENCE (KVAL,RVAL)
  3357.       INTEGER LINE(7)
  3358.       LOGICAL EQKEYW
  3359.         Include DCLAR1.BLK
  3360.         Include DCLAR6.BLK
  3361. C
  3362. C  FIND THE ATTRIBUTE IN THE ATTRIBUTE TABLE.
  3363.       INTEGER SWITCP
  3364.       INTEGER IT(5)
  3365.       REAL RIT(5)
  3366.       EQUIVALENCE (IT,RIT)
  3367.       LIT = (20-1)/CHPWD+1
  3368. C
  3369.       ANAME = BLANK
  3370.       CALL LXSREC(3,1,8,ANAME,1)
  3371.       I = LOCATT(ANAME,NAME)
  3372.       IF(I.EQ.0) GO TO 100
  3373.       CALL WARN(3,ANAME,NAME)
  3374.       GO TO 9999
  3375.   100 CONTINUE
  3376. C
  3377. C  GET THE TYPE AND LENGTH FOR THIS ATTRIBUTE.
  3378. C
  3379.       CALL ATTGET(ISTAT)
  3380.       CALL TYPER(ATTYPE,MATVEC,ITYPE)
  3381. C
  3382. C  DETERMINE THE TYPE OF FUNCTION REQUESTED.
  3383. C
  3384.       FTYPE = 0
  3385.       IF(LXWREC(2,1).EQ.K4MIN ) FTYPE = 1
  3386.       IF(LXWREC(2,1).EQ.K4MAX ) FTYPE = 2
  3387.       IF(LXWREC(2,1).EQ.K4AVE ) FTYPE = 3
  3388.       IF(LXWREC(2,1).EQ.K4SUM ) FTYPE = 4
  3389.       IF(EQKEYW(2,KWCOUN,5)) FTYPE = 5
  3390.       IF(FTYPE.NE.0) GO TO 300
  3391.       WRITE(NOUT,9000)
  3392.  9000 FORMAT(35H -ERROR- UNRECOGNIZED FUNCTION TYPE  )
  3393.       GO TO 9999
  3394. C
  3395. C  PROCESS THE FUNCTION.
  3396. C
  3397.   300 CONTINUE
  3398.       IF(ATTWDS.LT.LIT) LIT = ATTWDS
  3399.       WHAT = BLANK
  3400.       CALL LXSREC(2,1,8,WHAT,1)
  3401.       IF(FTYPE.GT.2) GO TO 550
  3402. C
  3403. C  MIN - MAX
  3404. C
  3405.       IF(ATTWDS.EQ.1) GO TO 320
  3406.       IF((ATTWDS.EQ.2).AND.(ITYPE.EQ.KZDOUB)) GO TO 320
  3407.       IF((ATTWDS.GT.0).AND.(ITYPE.EQ.KZTEXT)) GO TO 320
  3408.       GO TO 8000
  3409. C
  3410. C  GET THE FIRST TUPLE
  3411. C
  3412.   320 CONTINUE
  3413.       CALL RMLOOK(IP,1,1,LENGTH)
  3414.       IPX = IP+ATTCOL-2
  3415.   325 CONTINUE
  3416.       DO 330 K=1,LIT
  3417.       IT(K) = BUFFER(IPX+K)
  3418.   330 CONTINUE
  3419.   350 CONTINUE
  3420.       CALL RMLOOK(IP,1,1,LENGTH)
  3421.       IF(RMSTAT.NE.0) GO TO 500
  3422.       IPX = IP+ATTCOL-2
  3423.       IF(BUFFER(IPX+1).EQ.NULL) GO TO 350
  3424.       IF(IT(1).EQ.NULL) GO TO 325
  3425.       IF(ITYPE.NE.KZTEXT) GO TO 390
  3426. C
  3427. C  TEXT COMPARE
  3428. C
  3429.       DO 360 K=1,LIT
  3430.       J = SWITCP(IT(K),BUFFER(IPX+K))
  3431.       IF(J.GT.0) GO TO 370
  3432.       IF(J.LT.0) GO TO 380
  3433.   360 CONTINUE
  3434.       GO TO 350
  3435.   370 CONTINUE
  3436.       IF(FTYPE.EQ.2) GO TO 325
  3437.       GO TO 350
  3438.   380 CONTINUE
  3439.       IF(FTYPE.EQ.1) GO TO 325
  3440.       GO TO 350
  3441. C
  3442. C  REAL,INT,DOUBLE
  3443. C
  3444.   390 CONTINUE
  3445.       IF(ITYPE.NE.KZINT) GO TO 400
  3446.       IF((FTYPE.EQ.1).AND.(BUFFER(IPX+1).LT.IT(1))) GO TO 325
  3447.       IF((FTYPE.EQ.2).AND.(BUFFER(IPX+1).GT.IT(1))) GO TO 325
  3448.       GO TO 350
  3449.   400 CONTINUE
  3450.       KVAL = BUFFER(IPX+1)
  3451.       IF((FTYPE.EQ.1).AND.(RVAL.LT.RIT(1))) GO TO 325
  3452.       IF((FTYPE.EQ.2).AND.(RVAL.GT.RIT(1))) GO TO 325
  3453.       GO TO 350
  3454.   500 CONTINUE
  3455.       GO TO 2000
  3456.   550 CONTINUE
  3457.       IF(FTYPE.GT.4) GO TO 750
  3458. C
  3459. C  AVE OR SUM.
  3460. C
  3461.       IF(ITYPE.EQ.KZDOUB) GO TO 560
  3462.       IF(ATTWDS.NE.1) GO TO 8000
  3463. C
  3464. C  DETERMINE IF WE HAVE REAL OR INT TYPE.
  3465. C
  3466.       IF(ITYPE.EQ.KZINT) GO TO 650
  3467.       IF(ITYPE.NE.KZREAL) GO TO 8100
  3468. C
  3469. C  REAL ATTRIBUTE.
  3470. C
  3471.   560 CONTINUE
  3472.       IF(ATTWDS.GT.2) GO TO 8000
  3473.       KOUNT = 0
  3474.       TOT = 0.0
  3475.   575 CONTINUE
  3476.       CALL RMLOOK(IP,1,1,LENGTH)
  3477.       IF(RMSTAT.NE.0) GO TO 625
  3478.       IF(BUFFER(IP+ATTCOL-1).EQ.NULL) GO TO 600
  3479.       KOUNT = KOUNT + 1
  3480.       KVAL = BUFFER(IP+ATTCOL-1)
  3481.       TOT = TOT + RVAL
  3482.   600 CONTINUE
  3483.       GO TO 575
  3484.   625 CONTINUE
  3485.       AVE = NULL
  3486.       IF(KOUNT.NE.0) AVE = TOT / FLOAT(KOUNT)
  3487.       RVAL = TOT
  3488.       IT(1) = KVAL
  3489.       IF(FTYPE.NE.3) GO TO 2000
  3490.       RVAL = AVE
  3491.       IT(1) = KVAL
  3492.       GO TO 2000
  3493.   650 CONTINUE
  3494. C
  3495. C  INT ATTRIBUTE.
  3496. C
  3497.       KOUNT = 0
  3498.       ITOT = 0
  3499.   675 CONTINUE
  3500.       CALL RMLOOK(IP,1,1,LENGTH)
  3501.       IF(RMSTAT.NE.0) GO TO 725
  3502.       IF(BUFFER(IP+ATTCOL-1).EQ.NULL) GO TO 700
  3503.       KOUNT = KOUNT + 1
  3504.       ITOT = ITOT + BUFFER(IP+ATTCOL-1)
  3505.   700 CONTINUE
  3506.       GO TO 675
  3507.   725 CONTINUE
  3508.       IAVE = NULL
  3509.       IF(KOUNT.NE.0) IAVE = ITOT / KOUNT
  3510.       IT(1) = ITOT
  3511.       IF(FTYPE.EQ.3) IT(1) = IAVE
  3512.       GO TO 2000
  3513.   750 CONTINUE
  3514. C
  3515. C  COUNT.
  3516. C
  3517.       KOUNT = 0
  3518.   775 CONTINUE
  3519.       CALL RMLOOK(IP,1,1,LENGTH)
  3520.       IF(RMSTAT.NE.0) GO TO 800
  3521.       KOUNT = KOUNT + 1
  3522.       GO TO 775
  3523.   800 CONTINUE
  3524.       IT(1) = KOUNT
  3525.       ITYPE = KZINT
  3526. C
  3527. C  PRINT OUT THE RESULTS.
  3528. C
  3529.  2000 CONTINUE
  3530. C
  3531. C  BLANK FILL LINE
  3532. C
  3533.       DO 2010 I=1,7
  3534.  2010 LINE(I) = IBLANK
  3535.       IF(IT(1).NE.NULL) GO TO 2050
  3536. C
  3537. C  NULL VALUE
  3538. C
  3539.       CALL STRMOV(NULL,1,3,LINE,7)
  3540.       GO TO 2100
  3541. C
  3542. C  WE HAVE A VALUE
  3543. C
  3544.  2050 CONTINUE
  3545.       IF(ITYPE.EQ.KZINT) CALL ITOC(LINE,7,10,IT,IERR)
  3546.       IF(ITYPE.EQ.KZREAL) CALL RTOC(LINE,7,10,IT)
  3547.       IF(ITYPE.EQ.KZDOUB) CALL RTOC(LINE,7,10,IT)
  3548.       IF(ITYPE.EQ.KZTEXT) CALL STRMOV(IT,1,CHPWD*LIT,LINE,7)
  3549.  2100 CONTINUE
  3550.       WRITE(NOUTR,9100) WHAT,ANAME
  3551.  9100 FORMAT(3X,A6,A8)
  3552.       WRITE(NOUTR,9200)
  3553.  9200 FORMAT(27H   ------------------------)
  3554.       CALL SPOUT(LINE,28)
  3555.       GO TO 9999
  3556. C
  3557. C  ERROR MESSAGES.
  3558. C
  3559. C  ATTRIBUTE LENGTH IS GREATER THAN 1.
  3560. C
  3561.  8000 CONTINUE
  3562.       WRITE(NOUT,9400)
  3563.  9400 FORMAT(26H -ERROR- FUNCTION WILL NOT,
  3564.      X       42H WORK ON MULTI-WORD OR VARIABLE ATTRIBUTES)
  3565.       GO TO 9999
  3566. C
  3567. C  TYPE IMPROPER FOR THE FUNCTION.
  3568. C
  3569.  8100 CONTINUE
  3570.       WRITE(NOUT,9500)
  3571.  9500 FORMAT(32H -ERROR- FUNCTION TYPE WILL ONLY,
  3572.      X       39H WORK ON REAL,DOUBLE AND INT ATTRIBUTES)
  3573.  9999 CONTINUE
  3574.       RETURN
  3575.       END
  3576.       SUBROUTINE CSC
  3577.         Include TEXT.BLK
  3578. C
  3579. C  THIS PROGRAM IS THE CONCEPTUAL SCHEMA COMPILER FOR RIM. CSC
  3580. C  COMPILES RIM CONCEPTUAL SCHEMAS INTO RIM INTERNAL SCHEMAS. ALL
  3581. C  CONCEPTUAL SCHEMAS ARE EXPRESSED IN TERMS OF THE RELATIONAL MODEL.
  3582. C
  3583.         Include CONST4.BLK
  3584.         Include CONST8.BLK
  3585.         Include RMKEYW.BLK
  3586.         Include RIMCOM.BLK
  3587.         Include FLAGS.BLK
  3588.         Include FILES.BLK
  3589.         Include MISC.BLK
  3590. C
  3591.       LOGICAL EQKEYW
  3592.       LOGICAL EQ
  3593.       INTEGER ERROR
  3594.       INTEGER EFLAG,RFLAG
  3595.       INTEGER DBSTAT
  3596.         Include DCLAR2.BLK
  3597.         Include DCLAR6.BLK
  3598. C
  3599.       EFLAG = 0
  3600.       RFLAG = 0
  3601.       NUMELE  = 0
  3602.       ERROR = 0
  3603.       NEWCSN = 0
  3604.       CALL RMDATE(IDAY)
  3605. C
  3606. C  SET THE PROMPT CHARACTER TO D (DEFINE)
  3607. C
  3608.       CALL LXSET(K4PROM,K4DP)
  3609. C
  3610. C  BEGIN PROCESSING.
  3611. C
  3612.       WRITE (NOUT,9000)
  3613.  9000 FORMAT(/,29H BEGIN RIM SCHEMA COMPILATION,/)
  3614.       GO TO 110
  3615. C
  3616.   100 CONTINUE
  3617. C
  3618. C  EDIT DATA BASE NAME.
  3619. C
  3620.       CALL LODREC
  3621. C
  3622. C  CHECK FOR END,INPUT, OR HELP
  3623. C
  3624.       IF(EQKEYW(1,KWEND,3)) GO TO 800
  3625.   110 CONTINUE
  3626.       IF((EQKEYW(1,KWDEFI,6)).AND.(LXITEM(IDUMMY).EQ.2)) GO TO 120
  3627.       WRITE (NOUT,9001)
  3628.  9001 FORMAT(31H -ERROR- MISSING DATA BASE NAME)
  3629.       IF(.NOT.BATCH) GO TO 100
  3630.       ERROR = ERROR + 1
  3631.       IF(ERROR.LT.10) GO TO 100
  3632.       GO TO 950
  3633.   120 CONTINUE
  3634. C
  3635. C  CHECK THAT THE NAME IS LESS THAN 6 CHARACTERS.
  3636. C
  3637.       IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.6)) GO TO 145
  3638.       WRITE (NOUT,9002)
  3639.  9002 FORMAT(39H -ERROR- THE DATABASE NAME MUST BE 1-6 ,
  3640.      X       23HALPHANUMERIC CHARACTERS,/)
  3641.       IF(.NOT.BATCH) GO TO 100
  3642.       ERROR = ERROR + 1
  3643.       IF(ERROR.LT.10) GO TO 100
  3644.       GO TO 950
  3645. C
  3646. C  STORE DATA BASE NAME
  3647. C
  3648.   145 CONTINUE
  3649.       NAMDB = BLANK
  3650.       CALL LXSREC(2,1,8,NAMDB,1)
  3651. C
  3652. C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
  3653. C
  3654.       CALL RMDBLK(NAMDB)
  3655.       IF(RMSTAT.NE.0) GO TO 150
  3656.       CALL RMDBGT(NAMDB,DBSTAT)
  3657.       IF(DBSTAT.NE.0) GO TO 100
  3658.       CALL RMOPEN(NAMDB)
  3659.       IF((RMSTAT.EQ.15).OR.(RMSTAT.EQ.0)) GO TO 155
  3660.   150 CALL WARN(RMSTAT,DBNAME,0)
  3661.       GO TO 999
  3662.   155 CONTINUE
  3663.       NEWCSN = 1
  3664.       IF(DFLAG) RFLAG = 1
  3665. C
  3666. C  EDIT OWNER CLAUSE
  3667. C
  3668.   200 CONTINUE
  3669.       CALL LODREC
  3670. C
  3671. C  CHECK FOR END,INPUT, OR HELP
  3672. C
  3673.       IF(EQKEYW(1,KWEND,3)) GO TO 800
  3674.       IF(EQKEYW(1,KWOWNE,5)) GO TO 220
  3675.       IF((DFLAG).AND.(EQ(OWNER,USERID))) GO TO 350
  3676.       GO TO 230
  3677. C
  3678.   220 CONTINUE
  3679.       IF(LXITEM(IDUMMY).EQ.2) GO TO 260
  3680.   230 CONTINUE
  3681.       WRITE (NOUT,9003)
  3682.  9003 FORMAT(35H -ERROR- AN OWNER MUST BE SPECIFIED)
  3683.       IF(.NOT.BATCH) GO TO 200
  3684.       ERROR = ERROR + 1
  3685.       IF(ERROR.LT.10) GO TO 200
  3686.       GO TO 950
  3687. C
  3688.   260 CONTINUE
  3689.       IF(.NOT.DFLAG) GO TO 290
  3690.       NAMOWN = BLANK
  3691.       CALL LXSREC(2,1,8,NAMOWN,1)
  3692.       IF(EQ(OWNER,NAMOWN)) GO TO 300
  3693.       WRITE (NOUT,9004)
  3694.  9004 FORMAT(59H -ERROR- UNAUTHORIZED ACCESS TO DATA BASE SCHEMA DEFINIT
  3695.      XION)
  3696.       IF(.NOT.BATCH) GO TO 200
  3697.  
  3698.       ERROR = ERROR + 1
  3699.       IF(ERROR.LT.10) GO TO 200
  3700.       GO TO 950
  3701.   290 CONTINUE
  3702.       IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.8)) GO TO 295
  3703.       CALL WARN(7,KWOWNE,BLANK)
  3704.       IF(.NOT.BATCH) GO TO 200
  3705.       ERROR = ERROR + 1
  3706.       IF(ERROR.LT.10) GO TO 200
  3707.       GO TO 950
  3708.   295 CONTINUE
  3709.       OWNER = BLANK
  3710.       CALL LXSREC(2,1,8,OWNER,1)
  3711. C
  3712. C  SEARCH FOR ATTRIBUTES, RELATIONS, RULES, PASSWORDS, OR END
  3713. C
  3714.   300 CONTINUE
  3715.       CALL LODREC
  3716.   350 CONTINUE
  3717.       IF(EQKEYW(1,KWELEM,8)) GO TO 400
  3718.       IF(EQKEYW(1,KWATTR,10)) GO TO 400
  3719.       IF(EQKEYW(1,KWRELA,9)) GO TO 500
  3720.       IF(EQKEYW(1,KWRULS,5)) GO TO 600
  3721.       IF(EQKEYW(1,KWPASS,9)) GO TO 700
  3722.       IF(EQKEYW(1,KWEND,3)) GO TO 800
  3723. C
  3724. C  ERROR.
  3725. C
  3726.       CALL WARN(4,0,0)
  3727.       IF(.NOT.BATCH) GO TO 300
  3728.       ERROR = ERROR + 1
  3729.       IF(ERROR.LT.10) GO TO 300
  3730.       GO TO 950
  3731. C
  3732. C  PROCESS ATTRIBUTES.
  3733. C
  3734.   400 CONTINUE
  3735.       CALL LODELE(NUMELE,ERROR)
  3736.       EFLAG = 1
  3737.       GO TO 350
  3738. C
  3739. C
  3740. C  PROCESS RELATIONS.
  3741. C
  3742.   500 CONTINUE
  3743.       IF(DFLAG) GO TO 525
  3744.       IF(EFLAG.EQ.1) GO TO 525
  3745.       WRITE (NOUT,9005)
  3746.  9005 FORMAT(66H -ERROR- NO ATTRIBUTES DEFINED - RELATION DEFINITION IS
  3747.      XIMPOSSIBLE )
  3748.       ERROR = ERROR + 1
  3749.       GO TO 300
  3750.   525 CONTINUE
  3751.       CALL LODREL(NUMELE,ERROR)
  3752.       RFLAG = 1
  3753.       GO TO 350
  3754. C
  3755. C  PROCESS RULES.
  3756. C
  3757.   600 CONTINUE
  3758.       IF(RFLAG.EQ.1) GO TO 625
  3759.       WRITE (NOUT,9006)
  3760.  9006 FORMAT(74H -ERROR- RELATIONS AND ATTRIBUTES MUST BE DEFINED IN ORD
  3761.      XER TO DEFINE RULES)
  3762.       ERROR = ERROR + 1
  3763.       GO TO 300
  3764. C
  3765. C
  3766.   625 CONTINUE
  3767.       CALL LODRUL
  3768.       GO TO 350
  3769. C
  3770. C  PROCESS PASSWORDS.
  3771. C
  3772.   700 CONTINUE
  3773.       IF(RFLAG.EQ.1) GO TO 725
  3774.       WRITE (NOUT,9007)
  3775.  9007 FORMAT(63H -ERROR- RELATIONS MUST BE DEFINED IN ORDER TO ASSIGN PA
  3776.      XSSWORDS)
  3777.       ERROR = ERROR + 1
  3778.       GO TO 300
  3779. C
  3780.   725 CONTINUE
  3781.       CALL LODPAS(ERROR)
  3782.       GO TO 350
  3783. C
  3784. C  PROCESS END.
  3785. C
  3786.   800 CONTINUE
  3787. C
  3788. C  SET THE RETURN CODE AND MAKE SURE A SCHEMA HAS BEEN DEFINED
  3789. C
  3790.       NEXTOP = K8RIM
  3791.       IF(NEWCSN.EQ.0) GO TO 999
  3792.       IF(.NOT.BATCH) ERROR = 0
  3793.       IF(ERROR.NE.0) GO TO 950
  3794.       WRITE (NOUT,9008) DBNAME
  3795.  9008 FORMAT(/,28H RIM SCHEMA COMPILATION FOR ,A8,12H IS COMPLETE,/)
  3796. C
  3797. C  BUFFER THE SCHEMA AND DATABASE OUT
  3798. C
  3799.       DFLAG = .TRUE.
  3800.       IFMOD = .TRUE.
  3801.       CALL RMOPEN(DBNAME)
  3802.       IF(RMSTAT.NE.0) CALL WARN(RMSTAT,DBNAME,0)
  3803.       GO TO 999
  3804. C
  3805. C  ERROR PROCESSING.
  3806. C
  3807.   950 CONTINUE
  3808.       WRITE (NOUT,9009)
  3809.  9009 FORMAT(43H -WARNING- ERRORS IN RIM SCHEMA COMPILATION)
  3810.       DFLAG = .TRUE.
  3811.       IFMOD = .TRUE.
  3812.       CALL RMOPEN(DBNAME)
  3813.       IF(RMSTAT.NE.0) CALL WARN(RMSTAT,DBNAME,0)
  3814. C
  3815. C  RETURN.
  3816. C
  3817.   999 CONTINUE
  3818. C
  3819. C RESET THE PROMPT CHARACTER TO R
  3820. C
  3821.       CALL LXSET(K4PROM,K4RP)
  3822.       CALL BLKCLR(10)
  3823.       RETURN
  3824.       END
  3825.       SUBROUTINE DBLOAD
  3826.         Include TEXT.BLK
  3827. C
  3828. C  THIS ROUTINE IS THE DRIVER FOR LOADING DATA VALUES IN THE
  3829. C  RIM DATA BASE.
  3830. C
  3831.         Include CONST8.BLK
  3832.         Include RMKEYW.BLK
  3833.         Include CONST4.BLK
  3834.         Include TUPLER.BLK
  3835.         Include RULCOM.BLK
  3836.         Include FILES.BLK
  3837.         Include BUFFER.BLK
  3838.         Include MISC.BLK
  3839.         Include FLAGS.BLK
  3840.         Include RIMCOM.BLK
  3841. C
  3842.       LOGICAL EQKEYW
  3843.         Include DCLAR1.BLK
  3844. C
  3845. C  CALL RMDBLK TO MAKE SURE THE DATABASE CAN BE MODIFIED
  3846. C
  3847.       CALL RMDBLK(DBNAME)
  3848.       IF(RMSTAT.EQ.0) GO TO 50
  3849.       CALL WARN(RMSTAT,DBNAME,0)
  3850.       GO TO 1000
  3851.    50 CONTINUE
  3852. C
  3853. C  SET THE PROMPT CHARACTER TO L (LOAD)
  3854. C
  3855.       CALL LXSET(K4PROM,K4LP)
  3856. C
  3857. C  LOOK FOR THE RELATION NAME.
  3858. C
  3859.       WRITE(NOUT,9000)
  3860.  9000 FORMAT(/,25H BEGIN -RIM- DATA LOADING )
  3861.       GO TO 200
  3862.   100 CONTINUE
  3863.       CALL LODREC
  3864.   200 CONTINUE
  3865.       IF(EQKEYW(1,KWLOAD,4)) GO TO 300
  3866.       IF(EQKEYW(1,KWEND,3)) GO TO 1000
  3867.       WRITE(NOUT,9001)
  3868.  9001 FORMAT(46H -ERROR- UNRECOGNIZED LOAD COMMAND - RETYPE IT)
  3869.       GO TO 100
  3870. C
  3871. C  RELATION NAME SPECIFIED.
  3872. C
  3873.   300 CONTINUE
  3874.       IF(LXITEM(IDUMMY).EQ.2) GO TO 400
  3875.       WRITE(NOUT,9002)
  3876.  9002 FORMAT(46H -ERROR- MISSING RELATION NAME ON LOAD COMMAND)
  3877.       GO TO 100
  3878.   400 CONTINUE
  3879.       RNAME = BLANK
  3880.       CALL LXSREC(2,1,8,RNAME,1)
  3881. C
  3882. C  CHECK FOR RULES FOR THIS RELATION
  3883. C
  3884.       CALL CHKRUL(RNAME)
  3885.       IF(RMSTAT.LT.110) GO TO 450
  3886.       IF(RMSTAT.EQ.110) WRITE(NOUT,410)
  3887.       IF(RMSTAT.EQ.111) WRITE(NOUT,420)
  3888.   410 FORMAT(35H -ERROR- UNRECOGNIZED RULE RELATION )
  3889.   420 FORMAT(50H -ERROR- MORE THAN 10 RULES APPLY TO THIS RELATION)
  3890.       GO TO 1000
  3891.   450 CONTINUE
  3892.       I = LOCREL(RNAME)
  3893.       IF(I.EQ.0) GO TO 600
  3894.   500 CONTINUE
  3895. C
  3896. C  UNRECOGNIZED RELATION NAME.
  3897. C
  3898.       CALL WARN(1,RNAME,0)
  3899.       GO TO 100
  3900.   600 CONTINUE
  3901.       CALL RELGET(ISTAT)
  3902.       IF(ISTAT.NE.0) GO TO 500
  3903. C
  3904. C  CHECK FOR AUTHORITY.
  3905. C
  3906.       L = LOCPRM(RNAME,2)
  3907.       IF(L.EQ.0) GO TO 700
  3908.       CALL WARN(9,RNAME,0)
  3909.       GO TO 1000
  3910. C
  3911. C  CALL LOADIT TO READ THE ACTUAL DATA CARDS.
  3912. C
  3913.   700 CONTINUE
  3914.       CALL BLKDEF(10,1,MAXCOL)
  3915.       KQ1 = BLKLOC(10)
  3916.       CALL LOADIT(BUFFER(KQ1))
  3917. C
  3918. C  UPDATE THE DATE OF LAST MODIFICATION.
  3919. C
  3920.       CALL RMDATE(RDATE)
  3921.       CALL RELPUT
  3922.       CALL BLKCLR(10)
  3923.       GO TO 200
  3924. C
  3925. C  END OF LOADING.
  3926. C
  3927.  1000 CONTINUE
  3928.       WRITE(NOUT,9003)
  3929.  9003 FORMAT(23H END -RIM- DATA LOADING )
  3930. C
  3931. C  SET THE PROMPT CHARACTER BACK TO R (RIM)
  3932. C
  3933.       CALL LXSET(K4PROM,K4RP)
  3934.       RETURN
  3935.       END
  3936. c        BLOCK DATA
  3937. c        COMMON /ATTBLE/I1
  3938. c        COMMON /BLNKFL/I2
  3939. c        COMMON /BTBUF/I3
  3940. c        COMMON /CDCDBS/I4
  3941. c        COMMON /CONST4/I5
  3942. c        COMMON /BUFFER/I6
  3943. c        COMMON /CONST8/I7
  3944. c        COMMON /F1COM/I8
  3945. c        COMMON /F2COM/I9
  3946. c        COMMON /F3COM/IA
  3947. c        COMMON /FILES/IB
  3948. c        COMMON /FLAGS/IC
  3949. c        COMMON /INCORE/ID
  3950. c        COMMON /KEYDAT/IE
  3951. c        COMMON /LXCARD/IF
  3952. c        COMMON /LXCIT/IG
  3953. c        COMMON /LXCON/IH
  3954. c        COMMON /LXGEN/II
  3955. c        COMMON /LXWRDS/IJ
  3956. c        COMMON /MISC/IK
  3957. c        COMMON /PTRCOM/IL
  3958. c        COMMON /RELTBL/IM
  3959. c        COMMON /RIMCOM/IN
  3960. c        COMMON /RIMPTR/IO
  3961. c        COMMON /RMATTS/IP
  3962. c        COMMON /RMKEYW/IR
  3963. c        COMMON /RMSBUF/IS
  3964. c        COMMON /RULCOM/IT
  3965. c        COMMON /SELCOM/IU
  3966. c        COMMON /SRTCOM/IW
  3967. c        COMMON /STACK/IX
  3968. c        COMMON /START/IY
  3969. c        COMMON /TUPLEA/IZ
  3970. c        COMMON /TUPLER/I0
  3971. c        COMMON /VARDAT/I11
  3972. c        COMMON /WHCOM/I12
  3973. c        END
  3974.       SUBROUTINE DELDAT(INDEX,ID)
  3975.         Include TEXT.BLK
  3976. C
  3977. C  PURPOSE:   DELINK A TUPLE FROM THE DATA FILE
  3978. C
  3979. C  PARAMETERS:
  3980. C         INDEX---BLOCK REFERENCE NUMBER
  3981. C         ID------PACKED ID WORD WITH OFFSET,IOBN
  3982.         Include F2COM.BLK
  3983.         Include RIMCOM.BLK
  3984.         Include BUFFER.BLK
  3985.         Include FLAGS.BLK
  3986. C
  3987.       INTEGER OFFSET
  3988. C
  3989. C  UNPAC THE ID WORD.
  3990. C
  3991.       CALL ITOH(OFFSET,IOBN,ID)
  3992. C
  3993. C  SEE IF THE NEEDED BLOCK IS CURRENTLY IN CORE.
  3994. C
  3995.       NUMBLK = 0
  3996.       DO 200 I=1,3
  3997.       IF(IOBN.EQ.CURBLK(I)) NUMBLK = I
  3998.   200 CONTINUE
  3999.       IF(NUMBLK.NE.0) GO TO 400
  4000.       NUMBLK = INDEX
  4001. C
  4002. C  WE MUST DO PAGING.
  4003. C
  4004. C  SEE IF THE CURRENT BLOCK NEEDS WRITING.
  4005. C
  4006.       IF(MODFLG(NUMBLK).EQ.0) GO TO 300
  4007. C
  4008. C  WRITE OUT THE CURRENT BLOCK.
  4009. C
  4010.       KQ1 = BLKLOC(NUMBLK)
  4011.       CALL RIOOUT(FILE2,CURBLK(NUMBLK),BUFFER(KQ1),LENBF2,IOS)
  4012.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  4013.   300 CONTINUE
  4014. C
  4015. C  READ IN THE NEEDED BLOCK.
  4016. C
  4017.       CALL BLKCHG(NUMBLK,LENBF2,1)
  4018.       KQ1 = BLKLOC(NUMBLK)
  4019.       CALL RIOIN(FILE2,IOBN,BUFFER(KQ1),LENBF2,IOS)
  4020.       CURBLK(NUMBLK) = IOBN
  4021.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  4022.   400 CONTINUE
  4023.       MODFLG(NUMBLK) = 1
  4024.       IFMOD = .TRUE.
  4025. C
  4026. C  CHANGE THE ID POINTER.
  4027. C
  4028.       KQ0 = BLKLOC(NUMBLK) - 1
  4029.       BUFFER(KQ0 + OFFSET) = -BUFFER(KQ0 + OFFSET)
  4030.       MODFLG(NUMBLK) = 1
  4031.       IFMOD = .TRUE.
  4032.       IF(BUFFER(KQ0 + OFFSET).NE.0) RETURN
  4033. C
  4034. C  SPECIAL STUFF FOR DELETING THE LAST TUPLE.
  4035. C
  4036.       CALL HTOI(1,0,BUFFER(KQ0 + OFFSET))
  4037.       BUFFER(KQ0 + OFFSET) = -BUFFER(KQ0 + OFFSET)
  4038.       RETURN
  4039.       END
  4040.       SUBROUTINE DELDUP(MAT)
  4041.         Include TEXT.BLK
  4042. C
  4043. C     DELETE DUPLICATES ROUTINE
  4044. C     MAT IS INPUT STORAGE OF LENGTH AT LEAST (MOST) THE FIXED
  4045. C     PORTION OF THE RELATION.  WHEN ATTRIBUTES ARE SPECIFIED, THIS
  4046. C     IS USED TO FLAG WHICH ARE NOT TO BE COMPARED (SET MAT TO 0) AND
  4047. C     WHICH ARE FIXED TO BE COMPARED (SET MAT TO 1) AND WHICH ARE
  4048. C     VARIABLE TO BE COMPARED (SET MAT TO -1).
  4049. C
  4050. C     METHOD - 1. SET MAT OR ALL
  4051. C              2. LOOP ON TUPLES
  4052. C                 3. LOOP ON SUBSEQUENT TUPLES
  4053. C                    IF NOT DUPLICATE GO TO 3
  4054. C                    IF DUPLICATE DELETEI FIRST TUPLE (INCLUDING KEYS)
  4055. C                    AND GO TO 2.
  4056. C              4. WHEN DONE RESET RSTART AND NTUPLE, PRINT MESSAGE,
  4057. C                  AND RETURN
  4058. C
  4059.         Include F2COM.BLK
  4060.         Include START.BLK
  4061.         Include RIMPTR.BLK
  4062.         Include RMKEYW.BLK
  4063.         Include TUPLER.BLK
  4064.         Include TUPLEA.BLK
  4065.         Include FILES.BLK
  4066.         Include MISC.BLK
  4067.         Include BUFFER.BLK
  4068.       DIMENSION MAT(1)
  4069.       LOGICAL IFALL
  4070.       INTEGER COLUMN
  4071.         Include DCLAR1.BLK
  4072. C
  4073. C     SEE IF THERE IS MORE THAN ONE TUPLE
  4074. C
  4075. C
  4076. C     LOCATE WORD FROM
  4077. C
  4078.       ITEMS = LXITEM(IDUMMY)
  4079.       J = LFIND(1,ITEMS,KWFROM,4)
  4080.       IFALL = .TRUE.
  4081.       IF(J.EQ.3) GO TO 200
  4082.       IFALL = .FALSE.
  4083. C
  4084. C     SET UP FOR SPECIFIED ATTRIBUTES
  4085. C
  4086.       DO 10 I=1,NCOL
  4087.       MAT(I) = 0
  4088.    10 CONTINUE
  4089.       II = ITEMS - 2
  4090.       DO 100 I=3,II
  4091.       ANAME = BLANK
  4092.       CALL LXSREC(I,1,8,ANAME,1)
  4093.       IF(LOCATT(ANAME,NAME).EQ.0) GO TO 20
  4094.       CALL WARN(3,ANAME,NAME)
  4095.       GO TO 9999
  4096.    20 CONTINUE
  4097.       CALL ATTGET(ISTAT)
  4098. C
  4099. C     GOT ATTRIBUTE - SET MAT
  4100. C
  4101.       MAT(ATTCOL) = -1
  4102.       IF(ATTWDS.EQ.0) GO TO 100
  4103. C
  4104. C     FIXED SET ALL COLUMNS
  4105. C
  4106.       NUM = ATTCOL - 1
  4107.       DO 60 J=1,ATTWDS
  4108.       NUM = NUM + 1
  4109.       MAT(NUM) = 1
  4110.    60 CONTINUE
  4111.   100 CONTINUE
  4112.   200 CONTINUE
  4113. C
  4114. C     DO DOUBLE LOOP ON TUPLES
  4115. C     ND COUNTS DELETED TUPLES
  4116. C     IID SAVES NEW RSTART
  4117. C
  4118.       ND = 0
  4119.       IF(NTUPLE.LE.1) GO TO 700
  4120. C
  4121. C  WRITE OUT PAGE 2 IF IT HAS BEEN MODIFIED
  4122. C
  4123.       IF(MODFLG(2).EQ.0) GO TO 250
  4124.       KQ2 = BLKLOC(2)
  4125.       CALL RIOOUT(FILE2,CURBLK(2),BUFFER(KQ2),LENBF2,IOS)
  4126.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  4127.       MODFLG(2) = 0
  4128.       CURBLK(2) = 0
  4129.   250 CONTINUE
  4130.       IID = NID
  4131.   300 CONTINUE
  4132. C
  4133. C     GET THE FIRST TUPLE
  4134. C
  4135.       IF(NID.EQ.0) GO TO 600
  4136.       CALL ITOH(N1,N2,NID)
  4137.       IF(N2.EQ.0) GO TO 600
  4138. C
  4139. C     FORCE INTO POSITION OTHER THAN 2
  4140. C
  4141.       ISAVE = CURBLK(2)
  4142.       CURBLK(2) = 0
  4143.       CID = NID
  4144.       CALL GETDAT(1,NID,IP1,LEN1)
  4145.       CURBLK(2) = ISAVE
  4146.       IF(NID.LT.0) GO TO 600
  4147.       IP1 = IP1 - 1
  4148. C
  4149. C     LOOP ON LATER TUPLES
  4150. C
  4151.       KNID = NID
  4152.       KCID = CID
  4153.   400 CONTINUE
  4154. C
  4155. C     GET THE FOLLOWING TUPLES
  4156. C
  4157.       IF(KNID.EQ.0) GO TO 300
  4158.       CALL ITOH(N1,N2,KNID)
  4159.       IF(N2.EQ.0) GO TO 300
  4160.       CALL GETDAT(2,KNID,IP2,LEN2)
  4161.       IF(KNID.LT.0) GO TO 300
  4162.       IP2 = IP2 - 1
  4163. C
  4164. C     COMPARE THE TWO TUPLES
  4165. C
  4166.       IF(IFALL) GO TO 500
  4167.       DO 490 I=1,NCOL
  4168.       IF(MAT(I).EQ.0) GO TO 490
  4169.       IF(MAT(I).LT.0) GO TO 450
  4170. C
  4171. C     FIXED COMPARE
  4172. C
  4173.       IF(BUFFER(IP1+I).NE.BUFFER(IP2+I)) GO TO 400
  4174.       GO TO 490
  4175.   450 CONTINUE
  4176. C
  4177. C     VARIABLE
  4178. C
  4179.       JP1 = BUFFER(IP1+I) + IP1
  4180.       JP2 = BUFFER(IP2+I) + IP2
  4181.       IF(BUFFER(JP1) .NE. BUFFER(JP2)) GO TO 400
  4182.       NW = BUFFER(JP1) + 1
  4183.       DO 460 J=1,NW
  4184.       JP1 = JP1 + 1
  4185.       JP2 = JP2 + 1
  4186.       IF(BUFFER(JP1).NE.BUFFER(JP2)) GO TO 400
  4187.   460 CONTINUE
  4188.   490 CONTINUE
  4189.       GO TO 550
  4190.   500 CONTINUE
  4191. C
  4192. C     CHECK ALL
  4193. C
  4194.       IF(LEN1.NE.LEN2) GO TO 400
  4195.       DO 520 I=1,LEN1
  4196.       IF(BUFFER(IP1+I).NE.BUFFER(IP2+I)) GO TO 400
  4197.   520 CONTINUE
  4198.   550 CONTINUE
  4199. C
  4200. C     DUPLICATE FOUND - DELINK IT
  4201. C
  4202.       CALL DELDAT (1,KCID)
  4203. C
  4204. C     PROCESS ANY KEY ATTRIBUTES
  4205. C
  4206.       J = LOCATT(BLANK,NAME)
  4207.   560 CONTINUE
  4208.       CALL ATTGET(ISTAT)
  4209.       IF(ISTAT.NE.0) GO TO 580
  4210.       IF(ATTKEY.EQ.0) GO TO 560
  4211.       COLUMN = ATTCOL
  4212.       IF(ATTWDS.NE.0) GO TO 570
  4213.       COLUMN = BUFFER(IP1+ATTCOL) + 2
  4214.   570 CONTINUE
  4215.       START = ATTKEY
  4216.       CALL BTREP(BUFFER(IP1+COLUMN),0,KCID,ATTYPE)
  4217.       GO TO 560
  4218.   580 CONTINUE
  4219.       IF (KCID .EQ. IID) IID = NID
  4220.       ND = ND + 1
  4221.       GO TO 300
  4222. C
  4223. C     CHANGE THE STARTING ID IF NEEDED
  4224. C
  4225.   600 CONTINUE
  4226.       CALL RELGET(ISTAT)
  4227.       RSTART = IID
  4228.       NTUPLE = NTUPLE - ND
  4229.       CALL RELPUT
  4230.   700 CONTINUE
  4231.       WRITE (NOUT,9001) ND,NAME
  4232.  9001 FORMAT(2X,I6,26H ROWS DELETED IN RELATION ,A8)
  4233.  9999 CONTINUE
  4234.       RETURN
  4235.       END
  4236.       SUBROUTINE DELETE(MAT)
  4237.         Include TEXT.BLK
  4238. C
  4239. C  THIS ROUTINE PROCESSES A DELETE IN RIM.
  4240. C
  4241. C  PARAMETERS
  4242. C         MAT-----ARRAY TO HOLD ONE TUPLE
  4243.         Include START.BLK
  4244.         Include TUPLER.BLK
  4245.         Include RMKEYW.BLK
  4246.         Include TUPLEA.BLK
  4247.         Include RIMCOM.BLK
  4248.         Include RIMPTR.BLK
  4249.         Include FILES.BLK
  4250.         Include MISC.BLK
  4251.       INTEGER COLUMN
  4252. C
  4253. C  DIMENSION STATEMENTS.
  4254. C
  4255.       DIMENSION MAT(1)
  4256. C
  4257.       ND = 0
  4258. C
  4259. C  PROCESS THE WHERE CLAUSE.
  4260. C
  4261.       ITEMS = LXITEM(ISTAT)
  4262.       LW = LFIND(1,ITEMS,KWWHER,5)
  4263.       IF(LW.NE.0) GO TO 100
  4264.       WRITE(NOUT,9000)
  4265.  9000 FORMAT(55H -ERROR- A WHERE CLAUSE IS REQUIRED ON A DELETE COMMAND)
  4266.       GO TO 9999
  4267.   100 CONTINUE
  4268.       CALL WHERE(LW)
  4269.       IF(RMSTAT.NE.0) GO TO 9999
  4270. C
  4271. C  SEQUENCE THROUGH THE DATA DELETING TUPLES.
  4272. C
  4273.       IF(NTUPLE.LE.0) GO TO 9999
  4274.       IID = CID
  4275.   200 CONTINUE
  4276.       CALL RMLOOK(MAT,1,0,LENGTH)
  4277.       IF(RMSTAT.NE.0) GO TO 700
  4278. C
  4279. C  DELINK THIS TUPLE.
  4280. C
  4281.       CALL DELDAT(1,CID)
  4282. C
  4283. C  PROCESS ANY KEY ATTRIBUTES.
  4284. C
  4285.       J = LOCATT(BLANK,NAME)
  4286.   400 CONTINUE
  4287.       CALL ATTGET(ISTAT)
  4288.       IF(ISTAT.NE.0) GO TO 600
  4289.       IF(ATTKEY.EQ.0) GO TO 400
  4290.       COLUMN = ATTCOL
  4291.       IF(ATTWDS.NE.0) GO TO 500
  4292.       COLUMN = MAT(ATTCOL)
  4293.       KURLEN = MAT(COLUMN)
  4294.       COLUMN = COLUMN + 2
  4295.   500 CONTINUE
  4296.       START = ATTKEY
  4297.       CALL BTREP(MAT(COLUMN),0,CID,ATTYPE)
  4298.       GO TO 400
  4299.   600 CONTINUE
  4300.       IF(CID.EQ.IID) IID = NID
  4301.       ND = ND + 1
  4302.       GO TO 200
  4303. C
  4304. C  CHANGE THE STARTING ID IF NEEDED.
  4305. C
  4306.   700 CONTINUE
  4307.       CALL RELGET(ISTAT)
  4308.       RSTART = IID
  4309.       NTUPLE = NTUPLE - ND
  4310.       CALL RELPUT
  4311.       RMSTAT = 0
  4312.  9999 CONTINUE
  4313.       WRITE(NOUT,9001) ND,NAME
  4314.  9001 FORMAT(2X,I6,26H ROWS DELETED IN RELATION ,A8)
  4315. C
  4316. C  DONE.
  4317. C
  4318.       RETURN
  4319.       END
  4320.       SUBROUTINE DROPF(IFILE)
  4321.         Include TEXT.BLK
  4322.       REAL*8 IFILE
  4323.       CHARACTER*8 NFILE
  4324.       INTEGER FILENO,NONE
  4325.       LOGICAL HERE
  4326.       DATA NONE /-9999/
  4327.       WRITE(NFILE,100) IFILE
  4328.       FILENO=NONE
  4329.   100 FORMAT(A8)
  4330.       INQUIRE(FILE=NFILE,NUMBER=FILENO,EXIST=HERE,IOSTAT=IOS)
  4331.       IF(.NOT.HERE)RETURN
  4332.       IF(IOS.NE.0)FILENO=30
  4333.       IF(FILENO.EQ.NONE)FILENO=30
  4334.       OPEN(UNIT=FILENO,FILE=NFILE,STATUS='OLD',IOSTAT=IOS)
  4335.       IF(IOS.NE.0) RETURN
  4336.       CLOSE(UNIT=FILENO,STATUS='DELETE')
  4337.       RETURN
  4338.       END
  4339.       LOGICAL FUNCTION EQ(WORD1,WORD2)
  4340.         Include TEXT.BLK
  4341. C
  4342. C  PURPOSE:   COMPARE WORD1 AND WORD2 FOR EQ
  4343. C
  4344. C  PARAMETERS:
  4345. C         WORD1---A WORD OF TEXT
  4346. C         WORD2---ANOTHER WORD OF TEXT
  4347. C         EQ------.TRUE. IF WORD1.EQ.WORD2
  4348. C                 .FALSE. IF NOT EQ
  4349.         Include DCLAR6.BLK
  4350. C
  4351.       EQ = WORD1.EQ.WORD2
  4352.       RETURN
  4353.       END
  4354.       LOGICAL FUNCTION EQKEYW(I,KEYW,LEN)
  4355.         Include TEXT.BLK
  4356. C
  4357. C     THIS FUNCTION COMPARES KEYW WITH ITEM I WHICH HAS BEEN
  4358. C     INPUT THRU LXLREC.
  4359. C
  4360. C     INPUT - I........ITEM NUMBER
  4361. C             KEYW.....STRING WITH KEYWORD IN IT
  4362. C             LEN......LENGTH OF FULL KEYWORD
  4363. C     OUTPUT- EQKEYW....TRUE. IFF
  4364. C                             A. ITEM I IS TEXT
  4365. C                         AND B. NUMBER OF CHARACTERS IN ITEM I
  4366. C                                IS GE MIN(3,LEN) AND LE LEN.
  4367. C                         AND C. ITEM IT MATCHES KEYWORD TO MINIMUM
  4368. C                                OF 8 AND THE NUMBER OF CHARACTERS
  4369. C                                IN ITEM I.
  4370. C
  4371.         Include RMATTS.BLK
  4372.       INTEGER KEYW(1)
  4373.       EQKEYW = .FALSE.
  4374.       IF(LXID(I).NE.KZTEXT) GO TO 1000
  4375.       N = LXLENC(I)
  4376.       MIN = 3
  4377.       IF(LEN.LT.MIN) MIN = LEN
  4378.       IF(N.LT.MIN) GO TO 1000
  4379.       IF(N.GT.LEN) GO TO 1000
  4380.       IF(N.GT.8) N = 8
  4381. C
  4382. C     COMPARE CHARACTERS
  4383. C
  4384.       DO 10 J=1,N
  4385.       CALL GETT(KEYW,J,ICHAR)
  4386.       IF(LXCREC(I,J).NE.ICHAR) GO TO 1000
  4387.    10 CONTINUE
  4388.       EQKEYW = .TRUE.
  4389.  1000 CONTINUE
  4390.       RETURN
  4391.       END
  4392.       SUBROUTINE F1CLO
  4393.         Include TEXT.BLK
  4394. C
  4395. C  PURPOSE:   CLOSE THE RIM DIRECTORY FILE - FILE 1
  4396. C
  4397.         Include CONST8.BLK
  4398.         Include F1COM.BLK
  4399.         Include RIMCOM.BLK
  4400.         Include ATTBLE.BLK
  4401.         Include RELTBL.BLK
  4402.         Include FLAGS.BLK
  4403. C
  4404. C  WRITE OUT THE RELATION BUFFER IF IT WAS MODIFIED.
  4405. C
  4406.       IF(RELMOD.EQ.0) GO TO 100
  4407.       CALL RIOOUT(FILE1,CRREC,RELBUF,LENBF1,IOS)
  4408.       IF(IOS.NE.0) RMSTAT = 2100 + IOS
  4409.   100 CONTINUE
  4410.       CRREC = 0
  4411.       RELMOD = 0
  4412. C
  4413. C  WRITE OUT THE ATTRIBUTE BUFFER IF IT WAS MODIFIED.
  4414. C
  4415.       IF(ATTMOD.EQ.0) GO TO 200
  4416.       CALL RIOOUT(FILE1,CAREC,ATTBUF,LENBF1,IOS)
  4417.       IF(IOS.NE.0) RMSTAT = 2100 + IOS
  4418.   200 CONTINUE
  4419.       CAREC = 0
  4420.       ATTMOD = 0
  4421. C
  4422. C  ZERO OUT RELBUF AND MOVE CONTROL VARIABLES THERE.
  4423. C
  4424.       CALL ZEROIT(RELBUF,LENBF1)
  4425.       CALL BLKMOV(RELBUF(1),DBNAME,2)
  4426.       CALL BLKMOV(RELBUF(3),K8RMDT,2)
  4427.       CALL BLKMOV(RELBUF(5),OWNER,2)
  4428.       CALL BLKMOV(RELBUF(7),DBDATE,2)
  4429.       CALL BLKMOV(RELBUF(9),DBTIME,2)
  4430.       RELBUF(11) = LF1REC
  4431.       RELBUF(12) = NRROW
  4432.       RELBUF(13) = NAROW
  4433. C
  4434. C  WRITE OUT THE CONTROL BLOCK.
  4435. C
  4436.       CALL RIOOUT(FILE1,1,RELBUF,LENBF1,IOS)
  4437.       IF(IOS.NE.0) RMSTAT = 2100 + IOS
  4438.       RETURN
  4439.       END
  4440.       SUBROUTINE F1OPN(FILE)
  4441.         Include TEXT.BLK
  4442. C
  4443. C  PURPOSE:   OPEN THE RIM DIRECTORY FILE - FILE 1
  4444. C
  4445. C  PARAMETERS:
  4446. C         FILE----NAME OF THE FILE TO USE FOR FILE1
  4447.         Include CONST8.BLK
  4448.         Include F1COM.BLK
  4449.         Include RIMCOM.BLK
  4450.         Include ATTBLE.BLK
  4451.         Include RELTBL.BLK
  4452.         Include FLAGS.BLK
  4453.       LOGICAL EQ
  4454.         Include DCLAR4.BLK
  4455. C
  4456. C  OPEN THE DIRECTORY FILE.
  4457. C
  4458.       CALL RIOOPN(FILE,FILE1,LENBF1,IOS)
  4459.       IF(IOS.NE.0) RMSTAT = 2100 + IOS
  4460. C
  4461. C  READ IN THE FIRST RECORD FROM THIS FILE.
  4462. C
  4463.       CALL RIOIN(FILE1,1,RELBUF,LENBF1,IOS)
  4464.       IF(IOS.NE.0) GO TO 500
  4465.       CRREC = 0
  4466. C
  4467. C  MOVE THE CONTROL DATA TO WHERE IT IS NEEDED.
  4468. C
  4469.       IF(EQ(RELBUF(3),K8RMDT)) GO TO 100
  4470.       RMSTAT = 10
  4471.       GO TO 1000
  4472.   100 CONTINUE
  4473.       IF(EQ(RELBUF(1),DBNAME)) GO TO 200
  4474.       RMSTAT = 11
  4475.       GO TO 1000
  4476.   200 CONTINUE
  4477.       CALL BLKMOV(OWNER,RELBUF(5),2)
  4478.       CALL BLKMOV(DBDATE,RELBUF(7),2)
  4479.       CALL BLKMOV(DBTIME,RELBUF(9),2)
  4480.       LF1REC = RELBUF(11)
  4481.       NRROW = RELBUF(12)
  4482.       NAROW = RELBUF(13)
  4483. C
  4484. C  SUCCESSFUL OPEN.
  4485. C
  4486.       DFLAG = .TRUE.
  4487.       RMSTAT = 0
  4488.       GO TO 9999
  4489. C
  4490. C  EMPTY FILE 1 - WRITE THE FIRST RECORD ON IT.
  4491. C
  4492.   500 CONTINUE
  4493.       CALL ZEROIT(RELBUF,LENBF1)
  4494.       CALL RIOOUT(FILE1,1,RELBUF,LENBF1,IOS)
  4495.       LF1REC = 1
  4496.       CAREC = 0
  4497.       CRREC = 0
  4498.       NRROW = 74
  4499.       NAROW = 227
  4500.       RMSTAT = 15
  4501.       GO TO 1000
  4502. C
  4503. C  UNABLE TO OPEN FILE 1.
  4504. C
  4505.  1000 CONTINUE
  4506.       DFLAG = .FALSE.
  4507.  9999 RETURN
  4508.       END
  4509.       SUBROUTINE F2CLO
  4510.         Include TEXT.BLK
  4511. C
  4512. C  PURPOSE:    CLOSE THE DATA RANDOM IO FILE - FILE 2
  4513. C
  4514.         Include CONST8.BLK
  4515.         Include F2COM.BLK
  4516.         Include RIMCOM.BLK
  4517.         Include BUFFER.BLK
  4518.         Include FLAGS.BLK
  4519. C
  4520.       INTEGER REC1
  4521. C
  4522. C  SEQUENCE THROUGH THE BUFFERS LOOKING FOR WRITE FLAGS.
  4523. C
  4524.       REC1 = 0
  4525.       DO 400 NUMB=1,4
  4526.       IF(NUMB.EQ.4) GO TO 100
  4527.       IF(CURBLK(NUMB).EQ.1) GO TO 100
  4528.       IF(MODFLG(NUMB).EQ.0) GO TO 400
  4529. C
  4530. C  WRITE IT OUT.
  4531. C
  4532.       KQ1 = BLKLOC(NUMB)
  4533.       CALL RIOOUT(FILE2,CURBLK(NUMB),BUFFER(KQ1),LENBF2,IOS)
  4534.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  4535.       MODFLG(NUMB) = 0
  4536.       CURBLK(NUMB) = 0
  4537.       CALL BLKCLR(NUMB)
  4538.       GO TO 400
  4539.   100 CONTINUE
  4540.       IF(REC1.EQ.1) GO TO 400
  4541.       IF(NUMB.NE.4) GO TO 200
  4542. C
  4543. C  READ IN THE CONTROL BLOCK FIRST.
  4544. C
  4545.       CALL BLKCHG(1,LENBF2,1)
  4546.       KQ1 = BLKLOC(1)
  4547.       CALL RIOIN(FILE2,1,BUFFER(KQ1),LENBF2,IOS)
  4548.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  4549.       GO TO 300
  4550. C
  4551. C  WRITE OUT THE CONTROL BLOCK.
  4552. C
  4553.   200 CONTINUE
  4554.       KQ1 = BLKLOC(NUMB)
  4555.   300 CONTINUE
  4556.       KQ0 = KQ1 - 1
  4557.       CALL BLKMOV(BUFFER(KQ0 + 1),DBNAME,2)
  4558.       CALL BLKMOV(BUFFER(KQ0 + 3),K8RMDT,2)
  4559.       CALL BLKMOV(BUFFER(KQ0 + 5),OWNER,2)
  4560.       CALL BLKMOV(BUFFER(KQ0 + 7),DBDATE,2)
  4561.       CALL BLKMOV(BUFFER(KQ0 + 9),DBTIME,2)
  4562.       BUFFER(KQ0 + 11) = LENBF2
  4563.       BUFFER(KQ0 + 12) = LF2REC
  4564.       BUFFER(KQ0 + 13) = LF2WRD
  4565.       CALL RIOOUT(FILE2,1,BUFFER(KQ1),LENBF2,IOS)
  4566.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  4567.       REC1 = 1
  4568.       IF(NUMB.EQ.4) GO TO 400
  4569.       MODFLG(NUMB) = 0
  4570.       CURBLK(NUMB) = 0
  4571.   400 CONTINUE
  4572.       RETURN
  4573.       END
  4574.       SUBROUTINE F2OPN(FILE)
  4575.         Include TEXT.BLK
  4576. C
  4577. C  PURPOSE:    OPEN A DATA RANDOM IO PAGING FILE - FILE 2
  4578. C
  4579. C  PARAMETERS:
  4580. C     INPUT:   FILE----NAME OF THE FILE TO USE FOR FILE 2
  4581. C
  4582.         Include CONST8.BLK
  4583.         Include F2COM.BLK
  4584.         Include FLAGS.BLK
  4585.         Include BUFFER.BLK
  4586.         Include RIMCOM.BLK
  4587.       LOGICAL EQ
  4588.         Include DCLAR4.BLK
  4589. C
  4590. C  OPEN UP THE PAGED DATA FILE.
  4591. C
  4592.       CALL RIOOPN(FILE,FILE2,LENBF2,IOS)
  4593.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  4594. C
  4595. C  SEE IF THE FILE EXISTS YET. IF SO, READ CONTROL DATA.
  4596. C
  4597.       CALL BLKDEF(1,LENBF2,1)
  4598.       KQ1 = BLKLOC(1)
  4599.       KQ0 = KQ1 - 1
  4600.       CALL RIOIN(FILE2,1,BUFFER(KQ1),LENBF2,IOS)
  4601.       IF(IOS.NE.0) GO TO 100
  4602.       IF(.NOT.EQ(DBNAME,BUFFER(KQ0 + 1))) GO TO 8000
  4603.       IF(.NOT.EQ(K8RMDT,BUFFER(KQ0 + 3))) GO TO 8000
  4604.       IF(.NOT.EQ(OWNER,BUFFER(KQ0 + 5))) GO TO 8000
  4605.       IF(.NOT.EQ(DBDATE,BUFFER(KQ0 + 7))) GO TO 8000
  4606.       IF(.NOT.EQ(DBTIME,BUFFER(KQ0 + 9))) GO TO 8000
  4607.       LENBF2 = BUFFER(KQ0 + 11)
  4608.       LF2REC = BUFFER(KQ0 + 12)
  4609.       LF2WRD = BUFFER(KQ0 + 13)
  4610.       GO TO 200
  4611. C
  4612. C  INITIALIZE THE CONTROL VARIABLES.
  4613. C
  4614.   100 CONTINUE
  4615.       LF2REC = 1
  4616.       LF2WRD = 20
  4617. C
  4618. C  WRITE OUT THE CONTROL BLOCK FOR THE FIRST TIME.
  4619. C
  4620.       CALL ZEROIT(BUFFER(KQ1),LENBF2)
  4621.       CALL BLKMOV(BUFFER(KQ0 + 1),DBNAME,2)
  4622.       CALL BLKMOV(BUFFER(KQ0 + 3),K8RMDT,2)
  4623.       CALL BLKMOV(BUFFER(KQ0 + 5),OWNER,2)
  4624.       CALL BLKMOV(BUFFER(KQ0 + 7),DBDATE,2)
  4625.       CALL BLKMOV(BUFFER(KQ0 + 9),DBTIME,2)
  4626.       BUFFER(KQ0 + 11) = LENBF2
  4627.       BUFFER(KQ0 + 12) = LF2REC
  4628.       BUFFER(KQ0 + 13) = LF2WRD
  4629.       CALL RIOOUT(FILE2,1,BUFFER(KQ1),LENBF2,IOS)
  4630.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  4631.  
  4632.   200 CONTINUE
  4633. C
  4634. C  INITIALIZE THE CONTROL BLOCKS.
  4635. C
  4636.       CURBLK(1) = 1
  4637.       CURBLK(2) = 0
  4638.       CURBLK(3) = 0
  4639.       CALL ZEROIT(MODFLG,3)
  4640.       RETURN
  4641. C
  4642. C  CONTROL VALUES DO NOT MATCH VALUES FROM FILE 1.
  4643. C
  4644.  8000 CONTINUE
  4645.       RMSTAT = 12
  4646.       RETURN
  4647.       END
  4648.       SUBROUTINE F3CLO
  4649.         Include TEXT.BLK
  4650. C
  4651. C  PURPOSE:    CLOSE THE B-TREE RANDOM IO FILE - FILE 3
  4652. C
  4653.         Include CONST8.BLK
  4654.         Include F3COM.BLK
  4655.         Include RIMCOM.BLK
  4656.         Include BTBUF.BLK
  4657.         Include FLAGS.BLK
  4658. C
  4659. C  SEQUENCE THROUGH THE INCORE BLOCKS LOOKING FOR WRITE FLAGS.
  4660. C
  4661.       DO 100 NUMB=1,NUMIC
  4662.       IF(ICORE(2,NUMB).EQ.0) GO TO 100
  4663. C
  4664. C  WRITE IT OUT.
  4665. C
  4666.       ISTRT = (NUMB-1) * LENBF3 + 1
  4667.       CALL RIOOUT(FILE3,ICORE(3,NUMB),CORE(ISTRT),LENBF3,IOS)
  4668.       IF(IOS.NE.0) RMSTAT = 2300 + IOS
  4669.   100 CONTINUE
  4670. C
  4671. C  WRITE OUT THE CONTROL BLOCK.
  4672. C
  4673.       CALL ZEROIT(CORE,LENBF3)
  4674.       CALL BLKMOV(CORE(1),DBNAME,2)
  4675.       CALL BLKMOV(CORE(3),K8RMDT,2)
  4676.       CALL BLKMOV(CORE(5),OWNER,2)
  4677.       CALL BLKMOV(CORE(7),DBDATE,2)
  4678.       CALL BLKMOV(CORE(9),DBTIME,2)
  4679.       CORE(11) = LENBF3
  4680.       CORE(12) = LF3REC
  4681.       CORE(13) = MOTREC
  4682.       CORE(14) = MOTADD
  4683.       CALL RIOOUT(FILE3,1,CORE,LENBF3,IOS)
  4684.       IF(IOS.NE.0) RMSTAT = 2300 + IOS
  4685.       RETURN
  4686.       END
  4687.       SUBROUTINE F3OPN(FILE)
  4688.         Include TEXT.BLK
  4689. C
  4690. C  PURPOSE:    OPEN A B-TREE RANDOM IO PAGING FILE - FILE 3
  4691. C
  4692. C  PARAMETERS:
  4693. C     INPUT:   FILE----NAME OF THE FILE TO USE FOR FILE 3
  4694. C
  4695.         Include CONST8.BLK
  4696.         Include F3COM.BLK
  4697.         Include FLAGS.BLK
  4698.         Include BTBUF.BLK
  4699.         Include START.BLK
  4700.         Include RIMCOM.BLK
  4701.       LOGICAL EQ
  4702.         Include DCLAR4.BLK
  4703. C
  4704. C  OPEN UP THE BTREE AND MOT FILE.
  4705. C
  4706.       CALL RIOOPN(FILE,FILE3,LENBF3,IOS)
  4707.       IF(IOS.NE.0) RMSTAT = 2300 + IOS
  4708. C
  4709. C  SEE IF THE FILE EXISTS YET. IF SO, READ CONTROL DATA.
  4710. C
  4711.       CALL RIOIN(FILE3,1,CORE,LENBF3,IOS)
  4712.       IF(IOS.NE.0) GO TO 100
  4713.       IF(.NOT.EQ(DBNAME,CORE(1))) GO TO 8000
  4714.       IF(.NOT.EQ(K8RMDT,CORE(3))) GO TO 8000
  4715.       IF(.NOT.EQ(OWNER,CORE(5))) GO TO 8000
  4716.       IF(.NOT.EQ(DBDATE,CORE(7))) GO TO 8000
  4717.       IF(.NOT.EQ(DBTIME,CORE(9))) GO TO 8000
  4718.       LENBF3 = CORE(11)
  4719.       LF3REC = CORE(12)
  4720.       MOTREC = CORE(13)
  4721.       MOTADD = CORE(14)
  4722.       GO TO 200
  4723. C
  4724. C  INITIALIZE THE CONTROL VARIABLES.
  4725. C
  4726.   100 CONTINUE
  4727.       START = 0
  4728.       LF3REC = 2
  4729.       MOTREC = 0
  4730.       MOTADD = LENBF3 + 1
  4731. C
  4732. C  WRITE OUT THE CONTROL BLOCK FOR THE FIRST TIME.
  4733. C
  4734.       CALL ZEROIT(CORE,LENBF3)
  4735.       CALL BLKMOV(CORE(1),DBNAME,2)
  4736.       CALL BLKMOV(CORE(3),K8RMDT,2)
  4737.       CALL BLKMOV(CORE(5),OWNER,2)
  4738.       CALL BLKMOV(CORE(7),DBDATE,2)
  4739.       CALL BLKMOV(CORE(9),DBTIME,2)
  4740.       CORE(11) = LENBF3
  4741.       CORE(12) = LF3REC
  4742.       CORE(13) = MOTREC
  4743.       CORE(14) = MOTADD
  4744.       CALL RIOOUT(FILE3,1,CORE,LENBF3,IOS)
  4745.       IF(IOS.NE.0) RMSTAT = 2300 + IOS
  4746.   200 CONTINUE
  4747. C
  4748. C  INITIALIZE THE TREE COMMON BLOCK.
  4749. C
  4750.       NUMIC = 0
  4751.       LAST = 0
  4752.       CALL ZEROIT(ICORE(1,1),60)
  4753.       RETURN
  4754. C
  4755. C  CONTROL VALUES DO NOT MATCH VALUES FROM FILE 1.
  4756. C
  4757.  8000 CONTINUE
  4758.       RMSTAT = 12
  4759.       RETURN
  4760.       END
  4761.       SUBROUTINE FILCH(STRING,CHAR1,NUM,CHAR)
  4762.         Include TEXT.BLK
  4763. C
  4764. C     THIS ROUTINE STUFFS NUM CHAR'S INTO STRING
  4765. C     STARTING AT CHAR1.
  4766. C
  4767.       INTEGER CHAR,STRING(1)
  4768.       INTEGER CHAR1
  4769.       DO 10 I=1,NUM
  4770.       CALL PUTT(STRING,CHAR1+I-1,CHAR)
  4771.    10 CONTINUE
  4772.       RETURN
  4773.       END
  4774.       SUBROUTINE GETDAT(INDEX,ID,LOCTUP,LENGTH)
  4775.         Include TEXT.BLK
  4776. C
  4777. C  PURPOSE:  GET A TUPLE FROM THE DATA FILE
  4778. C
  4779. C  PARAMETERS:
  4780. C         INDEX---BLOCK REFERENCE NUMBER
  4781. C         ID------PACKED ID WORD WITH START,PRU
  4782. C         LOCTUP--OFFSET IN BUFFER FOR THE TUPLE
  4783. C         LENGTH---LENGTH OF THE TUPLE
  4784.         Include F2COM.BLK
  4785.         Include RIMCOM.BLK
  4786.         Include BUFFER.BLK
  4787.         Include RIMPTR.BLK
  4788. C
  4789.       INTEGER OFFSET
  4790. C
  4791. C  UNPAC THE ID WORD.
  4792. C
  4793.       CALL ITOH(OFFSET,IOBN,ID)
  4794.   100 CONTINUE
  4795. C
  4796. C  MAKE SURE WE HAVE A VALID ID.
  4797. C
  4798.       IF(IOBN.GT.LF2REC) GO TO 600
  4799.       IF(OFFSET.GT.LENBF2) GO TO 600
  4800. C
  4801. C  SEE IF THE NEEDED BLOCK IS CURRENTLY IN CORE.
  4802. C
  4803.       NUMBLK = 0
  4804.       DO 200 I=1,3
  4805.       IF(IOBN.EQ.CURBLK(I)) NUMBLK = I
  4806.   200 CONTINUE
  4807.       IF(NUMBLK.NE.0) GO TO 400
  4808.       NUMBLK = INDEX
  4809. C
  4810. C  WE MUST DO PAGING.
  4811. C
  4812. C  SEE IF THE CURRENT BLOCK NEEDS WRITING.
  4813. C
  4814.       IF(MODFLG(NUMBLK).EQ.0) GO TO 300
  4815. C
  4816. C  WRITE OUT THE CURRENT BLOCK.
  4817. C
  4818.       KQ1 = BLKLOC(NUMBLK)
  4819.       CALL RIOOUT(FILE2,CURBLK(NUMBLK),BUFFER(KQ1),LENBF2,IOS)
  4820.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  4821.   300 CONTINUE
  4822. C
  4823. C  READ IN THE NEEDED BLOCK.
  4824. C
  4825.       CALL BLKCHG(NUMBLK,LENBF2,1)
  4826.       KQ1 = BLKLOC(NUMBLK)
  4827.       CALL RIOIN(FILE2,IOBN,BUFFER(KQ1),LENBF2,IOS)
  4828.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  4829.       CURBLK(NUMBLK) = IOBN
  4830.       MODFLG(NUMBLK) = 0
  4831.   400 CONTINUE
  4832. C
  4833. C  MOVE THE DESIRED DATA.
  4834. C
  4835.       KQ0 = BLKLOC(NUMBLK) - 1
  4836.       ID = BUFFER(KQ0 + OFFSET)
  4837.       IF(ID.GE.0) GO TO 500
  4838. C
  4839. C  THIS TUPLE IS NOT ACTIVE. GO TO THE NEXT ONE.
  4840. C
  4841.       ID = -ID
  4842.       CID = ID
  4843.       ISOFF = OFFSET
  4844.       CALL ITOH(OFFSET,IOBN,ID)
  4845.       IF(IOBN.NE.0) GO TO 100
  4846. C
  4847. C  WE HAVE AN INACTIVE LAST TUPLE.
  4848. C
  4849.       ID = -ID
  4850.       OFFSET = ISOFF
  4851.   500 CONTINUE
  4852.       LOCTUP = KQ0 + OFFSET + 2
  4853.       LENGTH = BUFFER(LOCTUP - 1)
  4854.       RETURN
  4855. C
  4856. C  BAD ID VALUE.
  4857. C
  4858.   600 CONTINUE
  4859.       ID = 0
  4860.       RETURN
  4861.       END
  4862.       SUBROUTINE GETT(STR1,IC1,WORD)
  4863.         Include TEXT.BLK
  4864. C
  4865. C  PURPOSE:   GET THE IC1 CHARACTER FROM STR1 AND PUT IN WORD
  4866. C
  4867. C  PARAMETERS:
  4868. C     STR1----STRING OF CHARACTERS
  4869. C     IC1-----THE CHARACTER WANTED
  4870. C     WORD----WORD TO GET THE CHARACTER (LEFT JUSTIFIED, BLANK FILL)
  4871. C
  4872.       CHARACTER*1 STR1(1)
  4873.       INTEGER WORD
  4874.       INTEGER CHWORD
  4875.       CHARACTER*1 CHAR(4)
  4876.       EQUIVALENCE (CHWORD,CHAR(1))
  4877.       INTEGER BLANK
  4878.     CHARACTER*4 CBLK
  4879.     EQUIVALENCE(BLANK,CBLK)
  4880.       DATA CBLK /'    '/
  4881.       CHWORD = BLANK
  4882.       CHAR(1) = STR1(IC1)
  4883.       WORD = CHWORD
  4884.       RETURN
  4885.       END
  4886.       SUBROUTINE GTSORT(MAT,INDEX,IFLAG,LENGTH)
  4887.         Include TEXT.BLK
  4888. C
  4889. C  PURPOSE:  READ IN TUPLES FROM THE SORTED DATA FILE
  4890. C
  4891. C  PARAMETERS:
  4892. C            MAT-----ARRAY TO HOLD ONE TUPLE (IF IFLAG = 1)
  4893. C                    POINTER TO TUPLE IN BUFFER (IF IFLAG = 0)
  4894. C           INDEX---PAGE BUFFER TO USE
  4895. C            IFLAG---0 IF THE TUPLE IS RETURNED IN MAT
  4896. C                    1 IF THE BUFFER POINTER IS RETURNED IN MAT
  4897. C                   -1 OPEN THE SORT FILE AND INITIALIZE
  4898. C            LENGTH--LENGTH OF TUPLE IN WORDS
  4899. C            INDPTR--MULTIPLE RMHUNT INDEX - USED TO ASSIGN FILES
  4900. C
  4901.         Include SRTCOM.BLK
  4902.         Include WHCOM.BLK
  4903.         Include RIMCOM.BLK
  4904.         Include BUFFER.BLK
  4905.         Include F2COM.BLK
  4906.         Include MISC.BLK
  4907. C
  4908.       DIMENSION MAT(1)
  4909.       INTEGER INFIL
  4910.       INFIL = 20
  4911. C
  4912. C  IF IFLAG IS NOT -1 SKIP THE SORT FILE/BUFFER INITIALIZATION
  4913. C
  4914.       IF(IFLAG.NE.-1) GO TO 500
  4915. C
  4916. C  FIRST CALL -----
  4917. C
  4918. C  REWIND THE SORT FILE NEEDED
  4919. C
  4920.       REWIND INFIL
  4921. C
  4922. C  ESTABLISH THE BUFFER POINTER
  4923. C
  4924. C  SEE IF THE CURRENT BLOCK NEEDS WRITING
  4925. C
  4926.       IF(INDEX.GT.3) GO TO 200
  4927.       IF(MODFLG(INDEX).EQ.0) GO TO 100
  4928. C
  4929. C  WRITE OUT THE CURRENT BLOCK
  4930. C
  4931.       KQ1 = BLKLOC(INDEX)
  4932.       CALL RIOOUT(FILE2,CURBLK(INDEX),BUFFER(KQ1),LENBF2,IOS)
  4933.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  4934.   100 MODFLG(INDEX) = 0
  4935.       CURBLK(INDEX) = 0
  4936. C
  4937. C  ESTABLISH THE NEW BUFFER BLOCK
  4938. C
  4939.   200 CONTINUE
  4940.       CALL BLKCHG(INDEX,MAXCOL,1)
  4941. C
  4942. C  SET THE TUPLES READ COUNTED TO 0
  4943. C
  4944.       NREAD = 0
  4945. C
  4946. C  ALL INITIALIZATION COMPLETE -- RETURN
  4947. C
  4948.       RETURN
  4949. C
  4950. C  READ IN A TUPLE FROM THE SORT FILE
  4951. C
  4952.   500 CONTINUE
  4953.       CALL BLKCHG(INDEX,MAXCOL,1)
  4954.       KQ1 = BLKLOC(INDEX) - 1
  4955.       NREAD = NREAD + 1
  4956.       IF(NREAD.GT.LIMTU) GO TO 900
  4957.       IF(NREAD.GT.NSORT) GO TO 900
  4958.       IF(FIXLT) GO TO 600
  4959. C
  4960. C  VARIABLE LENGTH TUPLES
  4961. C
  4962.       READ(INFIL) LENGTH,(BUFFER(KQ1+K),K=1,LENGTH)
  4963.       GO TO 700
  4964. C
  4965. C  FIXED LENGTH TUPLES
  4966. C
  4967.   600 CONTINUE
  4968.       READ(INFIL) (BUFFER(KQ1+K),K=1,LENGTH)
  4969. C
  4970. C  TUPLE READ - SET MAT AND RMSTAT
  4971. C
  4972.   700 CONTINUE
  4973.       RMSTAT = 0
  4974.       MAT(1) = KQ1 + 1
  4975.       IF(IFLAG.NE.0) GO TO 999
  4976. C
  4977. C  LOAD TUPLE INTO MAT
  4978. C
  4979.       DO 800 K=1,LENGTH
  4980.       MAT(K) = BUFFER(KQ1+K)
  4981.   800 CONTINUE
  4982.       GO TO 999
  4983. C
  4984. C  ALL DONE - SET RMSTAT AND CLOSE THE FILE
  4985. C
  4986.   900 CONTINUE
  4987.       RMSTAT = -1
  4988.       CALL BLKCLR(INDEX)
  4989.       CLOSE(UNIT=INFIL,STATUS='DELETE')
  4990. C
  4991.   999 CONTINUE
  4992.       RETURN
  4993.       END
  4994.       SUBROUTINE HASH(TEMP,N)
  4995.         Include TEXT.BLK
  4996.       INTEGER TEMP(8)
  4997.       DO 20 I=1,N
  4998.       J = TEMP(7)
  4999.       TEMP(7) = TEMP(1)
  5000.       TEMP(1) = TEMP(4)
  5001.       TEMP(4) = TEMP(6)
  5002.       TEMP(6) = TEMP(8)
  5003.       TEMP(8) = TEMP(3)
  5004.       TEMP(3) = TEMP(5)
  5005.       TEMP(5) = TEMP(2)
  5006.       TEMP(2) = J
  5007.    20 CONTINUE
  5008.       RETURN
  5009.       END
  5010.       SUBROUTINE HASHIN(PASS,NUM,HASHP,ICHAR)
  5011.         Include TEXT.BLK
  5012. C
  5013. C     THIS ROUTINE HASHES AN 8 CHARACTER PASSWORD INTO A 16
  5014. C     CHARACTER HASHED PASSWORD.
  5015. C     1. ADD 8 CHARACTERS OF GARBAGE EVERY OTHER ONE.
  5016. C     2. ADD OLD PASSWORD SWITCHING E'S AND BLANKS.
  5017. C     3. CYCLE 1ST AND LAST HALF NUM TIMES.
  5018. C     4. PACK INTO OUTPUT STRING
  5019. C
  5020.         Include CONST4.BLK
  5021.         Include CONST8.BLK
  5022.         Include MISC.BLK
  5023.       INTEGER TEMP(16)
  5024.       INTEGER PASS(1)
  5025. C
  5026. C     WORD1 CONTAINS THE HASH SEQUENCE
  5027. C
  5028.       J = 0
  5029.       DO 10 I=2,16,2
  5030.       J = J+1
  5031.       CALL GETT (K8XXX,J,TEMP(I))
  5032.    10 CONTINUE
  5033.       J = 0
  5034.       DO 20 I=1,15,2
  5035.       J = J + 1
  5036.       CALL GETT(PASS,J,TEMP(I))
  5037.       K = TEMP(I)
  5038.       IF (TEMP(I) .EQ. IBLANK) K = K4E
  5039.       IF (TEMP(I) .EQ. K4E) K = IBLANK
  5040.       TEMP(I) = K
  5041.    20 CONTINUE
  5042.       CALL HASH(TEMP(1),NUM)
  5043.       CALL HASH(TEMP(9),NUM)
  5044.       CALL HASH(TEMP(4),NUM)
  5045.       DO 30 I=1,16
  5046.       CALL PUTT(HASHP,I + ICHAR - 1,TEMP(I))
  5047.    30 CONTINUE
  5048.       RETURN
  5049.       END
  5050.       SUBROUTINE HTOI(I,J,K)
  5051.         Include TEXT.BLK
  5052. C
  5053. C  PURPOSE:   PACK I AND J INTO K
  5054. C
  5055. C  OFFSET I BY MULTIPLYING BY 100000.
  5056. C
  5057.       K = J + (100000 * I)
  5058.       RETURN
  5059.       END
  5060.       INTEGER FUNCTION IEXP(REAL)
  5061.         Include TEXT.BLK
  5062. C
  5063. C     THIS FUNCTION RETURNS THE BASE TEN EXPONENT OF A REAL
  5064. C
  5065.       IE = -1000000
  5066.       IF(REAL.EQ.0.) GO TO 999
  5067.       X = ALOG10(ABS(REAL))
  5068.       IE = INT(X) + 1
  5069.       IF(X.LT.0.) IE = 1 + (INT(1000.+X)-1000)
  5070.   999 CONTINUE
  5071.       IEXP = IE
  5072.       RETURN
  5073.       END
  5074.       FUNCTION IFRT(WORD)
  5075.         Include TEXT.BLK
  5076. C
  5077. C  PURPOSE:   HASH WORD IN TO AN INTEGER
  5078. C
  5079. C  PARAMETERS:
  5080. C         WORD----A WORD OF TEXT
  5081. C         IFRT----AN INTEGER WHICH CORRESPONDS TO THE WORD
  5082. C
  5083.       REAL*8 WORD
  5084.       REAL*8 CHWORD
  5085.       CHARACTER*1 CH(8)
  5086.       EQUIVALENCE (CH(1),CHWORD)
  5087.       INTEGER POWER
  5088. C
  5089.       CHWORD = WORD
  5090.       NUM = 0
  5091.       POWER = 1
  5092. C
  5093. C  TURN LETTERS INTO NUMBERS.
  5094. C
  5095.       DO 100 I=1,8
  5096.       K = ICHAR(CH(9-I))
  5097.       K = K + 10
  5098.       NUM = NUM + K * POWER
  5099.       POWER = POWER * 10
  5100.   100 CONTINUE
  5101.       IFRT = NUM
  5102.       RETURN
  5103.       END
  5104.       SUBROUTINE INTCON(INTOPT)
  5105.         Include TEXT.BLK
  5106. C
  5107. C  PURPOSE:  THIS ROUTINE PROMPTS THE USER FOR THE EXECUTION
  5108. C            OPTION DESIRED (CREATE,UPDATE OR QUERY) AND CALLS
  5109. C            THE APPROPRIATE SUBROUTINES.
  5110. C
  5111. C  PARAMETERS: INTOPT - MENU MODE OPTION CODE
  5112. C                       4HMENU - DISPLAY MENU
  5113. C                       3HCRE -- CREATE MODE
  5114. C                       3HUPD -- UPDATE MODE
  5115. C                       3HQUE -- QUERY MODE
  5116. C
  5117.         Include RMATTS.BLK
  5118.         Include RMKEYW.BLK
  5119.         Include CONST4.BLK
  5120.         Include FLAGS.BLK
  5121.         Include FILES.BLK
  5122.         Include RIMCOM.BLK
  5123.         Include MISC.BLK
  5124. C
  5125.       INTEGER DBSTAT
  5126.       LOGICAL EQKEYW
  5127.         Include DCLAR2.BLK
  5128. C
  5129. C     ******************************************************
  5130. C
  5131. C               I N I T I A L I Z A T I O N
  5132. C
  5133. C     ******************************************************
  5134. C
  5135.       NAMDB = DBNAME
  5136.       IF((INTOPT.EQ.K4CRE).OR.(INTOPT.EQ.K4UPD)) GO TO 150
  5137.       IF(INTOPT.EQ.K4LOD) GO TO 255
  5138. C
  5139. C     REQUEST THE EXECUTION OPTION - IDBT
  5140. C       IDBT = 1: CREATE A NEW DATABASE
  5141. C       IDBT = 2: UPDATE AN EXISTING DATABASE
  5142. C       IDBT = 3: QUERY
  5143. C       IDBT = 4: COMMAND MODE
  5144. C       IDBT = 5: EXIT
  5145. C
  5146.       IDBT = 0
  5147.   100 WRITE(NOUT,110)
  5148.   110 FORMAT(/,1X,35HSELECT THE EXECUTION OPTION DESIRED,/
  5149.      1   5X,24H1) CREATE A NEW DATABASE,/
  5150.      2   5X,30H2) UPDATE AN EXISTING DATABASE,/
  5151.      3   5X,29H3) QUERY AN EXISTING DATABASE,/
  5152.      4   5X,21H4) ENTER COMMAND MODE,/
  5153.      5   5X, 7H5) EXIT,/)
  5154.       CALL LXLREC(DUM1,0,LXERR)
  5155.       IXID1 = LXID(1)
  5156.       IF(IXID1.EQ.K4EOF) GO TO 998
  5157.       IXREC1 = 0
  5158.       IF(IXID1.EQ.KZINT) IXREC1 = LXIREC(1)
  5159.       IF(EQKEYW(1,KWQUIT,4)) GO TO 997
  5160.       IF(EQKEYW(1,KWEXIT,4)) GO TO 998
  5161.       IDBT = IXREC1
  5162.       IF(IDBT.EQ.4) GO TO 400
  5163.       IF(IDBT.EQ.5) GO TO 998
  5164.       IF(IDBT.GT.0.AND.IDBT.LT.5) GO TO 120
  5165.       WRITE(NOUT,8001)
  5166.       GO TO 100
  5167. C
  5168. C     REQUEST THE DATABASE NAME - NAMDB
  5169. C
  5170.   120 WRITE(NOUT,130)
  5171.   130 FORMAT(/,1X,30HENTER THE NAME OF THE DATABASE,/)
  5172.       CALL LXLREC(DUM1,0,LXERR)
  5173.       IXID1 = LXID(1)
  5174.       IF(IXID1.EQ.K4EOF) GO TO 120
  5175.       IXREC1 = LXWREC(1,1)
  5176.       IF(EQKEYW(1,KWQUIT,4)) GO TO 997
  5177.       IXLEN = LXLENC(1)
  5178.       IF((IXID1.EQ.KZTEXT).AND.(IXLEN.LE.6)) GO TO 140
  5179.       WRITE(NOUT,8002)
  5180.       GO TO 120
  5181.   140 NAMDB = BLANK
  5182.       CALL LXSREC(1,1,8,NAMDB,1)
  5183.       IF(IDBT.NE.1) GO TO 180
  5184. C
  5185. C  CREATE MODE - CALL INTDEF TO DEFINE THE SCHEMA
  5186. C
  5187.       INTOPT = K4CRE
  5188. C
  5189. C  CHECK THAT THE DATABASE MAY BE MODIFIED
  5190. C
  5191.       CALL RMDBLK(NAMDB)
  5192.       IF(RMSTAT.NE.0) GO TO 215
  5193.       CALL INTDEF(NAMDB,INTOPT)
  5194.       IF(INTOPT.EQ.0) GO TO 100
  5195.       GO TO 999
  5196. C
  5197. C  DETERMINE IF THE DATABASE IS TO BE LOADED INTERACTIVELY
  5198. C
  5199.   150 CONTINUE
  5200. C
  5201. C     DETERMINE IF THE DATABASE IS TO BE LOADED
  5202. C
  5203.   160 WRITE(NOUT,170)
  5204.   170 FORMAT(/,1X,41HDO YOU WANT TO LOAD THE DATABASE - Y OR N,/)
  5205.       CALL LXLREC(DUM1,0,LXERR)
  5206.       IXID1 = LXID(1)
  5207.       IF(IXID1.EQ.K4EOF) GO TO 260
  5208.       IXREC1 = 0
  5209.       IF(IXID1.EQ.KZINT) IXREC1 = LXIREC(1)
  5210.       IF(IXID1.EQ.KZTEXT) IXREC1 = LXWREC(1,1)
  5211.       IF(EQKEYW(1,KWQUIT,4)) GO TO 997
  5212.       IF(IXREC1.EQ.K4Y) GO TO 250
  5213.       IF(IXREC1.EQ.K4N) GO TO 260
  5214.       WRITE(NOUT,8004)
  5215.       GO TO 160
  5216. C
  5217. C  QUERY AND UPDATE MODE - GET THE DATABASE
  5218. C
  5219.   180 CONTINUE
  5220.       CALL RMDBGT(NAMDB,DBSTAT)
  5221.       IF(DBSTAT.EQ.0) GO TO 200
  5222.       IF(DBSTAT.EQ.1) GO TO 100
  5223.       GO TO 997
  5224.   200 CONTINUE
  5225. C
  5226. C     CHECK THAT USER DATABASE NAME MATCHES THE FILE DATABASE NAME
  5227. C
  5228.       CALL RMOPEN(NAMDB)
  5229.       IF(RMSTAT.EQ.0) GO TO 210
  5230.       CALL WARN(RMSTAT,NAMDB,0)
  5231.       RMSTAT = 0
  5232.       GO TO 120
  5233.   210 CONTINUE
  5234.       IF(IDBT.EQ.3) GO TO 300
  5235. C
  5236. C  CHECK THAT THE DATABASE MAY BE MODIFIED
  5237. C
  5238.       CALL RMDBLK(NAMDB)
  5239.       IF(RMSTAT.EQ.0) GO TO 220
  5240.   215 CALL WARN(RMSTAT,NAMDB,0)
  5241.       RMSTAT = 0
  5242.       GO TO 100
  5243. C
  5244. C     REQUEST THE UPDATE OPTION
  5245. C       1 -- DEFINE ADDITIONAL RELATIONS
  5246. C            (BRANCH TO THE DEFINE SECTION)
  5247. C       2 -- LOAD ADDITIONAL DATA
  5248. C            (BRANCH TO THE LOAD SECTION)
  5249. C
  5250.   220 WRITE(NOUT,230)
  5251.   230 FORMAT(/,1X,32HSELECT THE UPDATE OPTION DESIRED,/
  5252.      1      5X,30H1) DEFINE ADDITIONAL RELATIONS,/
  5253.      2      5X,23H2) LOAD ADDITIONAL DATA,/)
  5254.       CALL LXLREC(DUM1,0,LXERR)
  5255.       IXID1 = LXID(1)
  5256.       IF(IXID1.EQ.K4EOF) GO TO 220
  5257.       IXREC1 = 0
  5258.       IF(IXID1.EQ.KZINT) IXREC1 = LXIREC(1)
  5259.       IF(IXID1.EQ.KZTEXT) IXREC1 = LXWREC(1,1)
  5260.       IF(EQKEYW(1,KWQUIT,4)) GO TO 997
  5261.       IF(IXREC1.EQ.1) GO TO 240
  5262.       IF(IXREC1.EQ.2) GO TO 250
  5263.       WRITE(NOUT,8003)
  5264.       GO TO 220
  5265. C
  5266. C  ADD NEW RELATIONS
  5267. C
  5268.   240 CONTINUE
  5269.       INTOPT = K4UPD
  5270.       CALL INTDEF(NAMDB,INTOPT)
  5271.       IF(INTOPT.EQ.0) GO TO 100
  5272.       GO TO 999
  5273. C
  5274. C  LOAD ADDITIONAL DATA
  5275. C
  5276.   250 CONTINUE
  5277.       INTOPT = 0
  5278.   255 CONTINUE
  5279.       CALL INTLOD(INTOPT)
  5280.       IF(INTOPT.EQ.K4QUE) GO TO 260
  5281.       GO TO 999
  5282. C
  5283. C  DETERMINE IF THE DATABASE IS TO BE QUERIED
  5284. C
  5285.   260 CONTINUE
  5286. C
  5287. C     DETERMINE IF THE DATABASE IS TO BE QUERIED
  5288. C
  5289.   270 WRITE(NOUT,280) NAMDB
  5290.   280 FORMAT(/,1X,5HTHE ",A7,35H" DATABASE HAS BEEN CREATED/UPDATED,/,/,
  5291.      1  1X,48HDO YOU WANT TO QUERY THE DATABASE AT THIS TIME -,
  5292.      2     7H Y OR N,/)
  5293.       CALL LXLREC(DUM1,0,LXERR)
  5294.       IXID1 = LXID(1)
  5295.       IF(IXID1.EQ.K4EOF) GO TO 100
  5296.       IXREC1 = 0
  5297.       IF(IXID1.EQ.KZINT) IXREC1 = LXIREC(1)
  5298.       IF(IXID1.EQ.KZTEXT) IXREC1 = LXWREC(1,1)
  5299.       IF(IXREC1.EQ.K4QUIT) GO TO 997
  5300.       IF(IXREC1.EQ.K4Y) GO TO 300
  5301.       IF(IXREC1.EQ.K4N) GO TO 100
  5302.       WRITE(NOUT,8004)
  5303.       GO TO 270
  5304. C
  5305. C  QUERY
  5306. C
  5307.   300 CONTINUE
  5308.       WRITE(NOUT,310)
  5309.   310 FORMAT(/,1X,16HRIM COMMAND MODE,/)
  5310.       INTOPT = K4QUE
  5311.       GO TO 999
  5312. C
  5313. C  COMMAND MODE
  5314. C
  5315.   400 CONTINUE
  5316.       INTOPT = K4COM
  5317.       WRITE(NOUT,310)
  5318.       GO TO 999
  5319. C
  5320. C  QUIT
  5321. C
  5322.   997 CONTINUE
  5323.       INTOPT = K4QUIT
  5324.       GO TO 999
  5325. C
  5326. C  EXIT
  5327. C
  5328.   998 CONTINUE
  5329.       INTOPT = K4EXIT
  5330.       CALL RMCLOS
  5331.   999 CONTINUE
  5332.       RETURN
  5333. C
  5334. C     ERROR MESSAGES ---------------------------------------
  5335. C
  5336.  8001 FORMAT(/,1X,49H-ERROR- EITHER "1","2","3" OR "4" MUST BE ENTERED,
  5337.      1     /)
  5338.  8002 FORMAT(/,1X,38H-ERROR- THE DATABASE NAME MUST BE 1-6 ,
  5339.      1           23HALPHANUMERIC CHARACTERS,/)
  5340.  8003 FORMAT(/,1X,41H-ERROR- EITHER "1" OR "2" MUST BE ENTERED,/)
  5341.  8004 FORMAT(/,1X,41H-ERROR- EITHER "Y" OR "N" MUST BE ENTERED,/)
  5342. C
  5343.       END
  5344.       SUBROUTINE INTDEF(NAMDB,INTOPT)
  5345.         Include TEXT.BLK
  5346. C
  5347. C  PURPOSE: THIS ROUTINE PROMPTS THE USER FOR THE INFORMATION
  5348. C           REQUIRED TO CREATE A RIM SCHEMA SOURCE FILE.
  5349. C           RELATIONS, ATTRIBUTES, AND PASSWORDS ARE DEFINED WITH THIS
  5350. C           ROUTINE. RULES ARE NOT CURRENTLY IMPLEMENTED.
  5351. C
  5352. C  PARAMETERS: NAMDB -- DATABASE NAME IN H FORMAT
  5353. C              INTOPT - MENU MODE OPTION CODE - SET TO 0 IF "QUIT"
  5354.     LOGICAL ISITIN
  5355. C
  5356. C
  5357.         Include RMATTS.BLK
  5358.         Include RMKEYW.BLK
  5359.         Include CONST4.BLK
  5360.         Include BUFFER.BLK
  5361.         Include FLAGS.BLK
  5362.         Include FILES.BLK
  5363.         Include TUPLEA.BLK
  5364.         Include RELTBL.BLK
  5365.         Include MISC.BLK
  5366. C
  5367.       DIMENSION IREL(25,53),IRELX(25),IATT(100),IATTX(100,4),IEDIT(10)
  5368. C
  5369. C  EQUIVALENCE THE LOCAL ARRAYS TO BUFFER - ALLOW TWO WORDS IN BUFFER
  5370. C  FOR EACH WORD IN THE LOCAL ARRAYS - SOLVES THE REAL*8 PROBLEM
  5371. C
  5372.       EQUIVALENCE (BUFFER(1),IREL(1,1))
  5373.       EQUIVALENCE (BUFFER(2651),IRELX(1))
  5374.       EQUIVALENCE (BUFFER(2701),IATT(1))
  5375.       EQUIVALENCE (BUFFER(2901),IATTX(1,1))
  5376.       LOGICAL EQKEYW
  5377.       INTEGER TWO
  5378.       INTEGER STATUS
  5379.         Include DCLAR1.BLK
  5380.         Include DCLAR2.BLK
  5381.         Include DCLAR3.BLK
  5382.         Include DCLAR5.BLK
  5383. C
  5384. C  CLEAR OUT ANY PAGE DATA LEFT IN BUFFER
  5385. C
  5386.       CALL BLKCLN
  5387. C
  5388. C     ******************************************************
  5389. C
  5390. C               D E F I N E   S E C T I O N
  5391. C
  5392. C     ******************************************************
  5393. C
  5394.       IRCD = 0
  5395.       IATC = 0
  5396.       TWO = 2
  5397. C
  5398. C     REQUEST THE DATABASE OWNER - NAMOWN
  5399. C
  5400.   100 WRITE(NOUT,110)
  5401.   110 FORMAT(/,1X,36HENTER THE NAME OF THE DATABASE OWNER,/)
  5402.   120 CALL LXLREC(DUM1,0,LXERR)
  5403.       IXID1 = LXID(1)
  5404.       IF(IXID1.EQ.K4EOF) GO TO 100
  5405.       IXREC1 = LXWREC(1,1)
  5406.       IF(IXREC1.EQ.K4QUIT) GO TO 998
  5407.       IXLEN = LXLENC(1)
  5408.       IF((IXID1.EQ.KZTEXT).AND.(IXLEN.LE.8)) GO TO 130
  5409.       WRITE(NOUT,8002)
  5410.       GO TO 100
  5411.   130 NAMOWN = BLANK
  5412.       CALL LXSREC(1,1,8,NAMOWN,1)
  5413. C
  5414. C     CHECK THE DATABASE OWNER
  5415. C
  5416.       IF(INTOPT.EQ.K4CRE) GO TO 140
  5417.       IF(NAMOWN.EQ.OWNER) GO TO 140
  5418.       WRITE(NOUT,8028)
  5419.       GO TO 120
  5420.   140 CONTINUE
  5421. C
  5422. C  OPEN THE SCHEMA SOURCE FILE
  5423. C
  5424. C ** ADD
  5425.     INQUIRE(FILE='SCHEMA',EXIST=ISITIN)
  5426.     IF(ISITIN) GOTO 145
  5427.       OPEN(TWO,FILE='SCHEMA',STATUS='NEW')
  5428.     GOTO 146
  5429. 145    CONTINUE
  5430.     OPEN(TWO,FILE='SCHEMA',STATUS='OLD')
  5431. 146    CONTINUE
  5432.       REWIND TWO
  5433.   310 IRCD = IRCD + 1
  5434.       IF(IRCD.LE.25) GO TO 320
  5435.       WRITE(NOUT,8020)
  5436.       IRCD = 25
  5437.       GO TO 830
  5438. C
  5439. C     REQUEST THE RELATION NAME - IREL(IRCD,1) WHERE
  5440. C     IRCD IS THE COUNT OF RELATIONS
  5441. C
  5442.   320 WRITE(NOUT,330)
  5443.   330 FORMAT(/,1X,40HENTER THE NAME ASSIGNED TO THIS RELATION,/)
  5444.       CALL LXLREC(DUM1,0,LXERR)
  5445.       IXID1 = LXID(1)
  5446.       IF(IXID1.EQ.K4EOF) GO TO 320
  5447.       IXREC1 = LXWREC(1,1)
  5448.       IF(IXREC1.EQ.K4QUIT) GO TO 998
  5449.       IXLEN = LXLENC(1)
  5450.       IF((IXID1.EQ.KZTEXT).AND.(IXLEN.LE.8)) GO TO 340
  5451.       WRITE(NOUT,8006)
  5452.       GO TO 320
  5453.   340 RNAME = BLANK
  5454.       CALL LXSREC(1,1,8,RNAME,1)
  5455.       IREL(IRCD,1) = RNAME
  5456. C
  5457. C     CHECK DUPLICATED RELATIONS
  5458. C
  5459.       IF(INTOPT.EQ.K4CRE) GO TO 350
  5460.       I = LOCREL(RNAME)
  5461.       IF(I.NE.0) GO TO 350
  5462.       WRITE(NOUT,8029) RNAME
  5463.       GO TO 320
  5464.   350 CONTINUE
  5465.       IF(IRCD.EQ.1) GO TO 380
  5466.       JEND = IRCD - 1
  5467.       DO 370 J=1,JEND
  5468.       IF(RNAME.NE.IREL(J,1)) GO TO 370
  5469.       WRITE(NOUT,8029) RNAME
  5470.       GO TO 320
  5471.   370 CONTINUE
  5472.   380 CONTINUE
  5473. C
  5474. C     REQUEST THE RELATION PASSWORDS
  5475. C
  5476.   390 WRITE(NOUT,400)
  5477.   400 FORMAT(/,1X,41HENTER THE READ PASSWORD FOR THIS RELATION,/)
  5478.       CALL LXLREC(DUM1,0,LXERR)
  5479.       RPW1 = BLANK
  5480.       IXID1 = LXID(1)
  5481.       IF(IXID1.EQ.K4EOF) GO TO 420
  5482.       IXREC1 = LXWREC(1,1)
  5483.       IF(IXREC1.EQ.K4QUIT) GO TO 998
  5484.       IXLEN = LXLENC(1)
  5485.       IF((IXID1.EQ.KZTEXT).AND.(IXLEN.LE.8)) GO TO 410
  5486.       WRITE(NOUT,8017)
  5487.       GO TO 390
  5488.   410 RPW1 = BLANK
  5489.       CALL LXSREC(1,1,8,RPW1,1)
  5490.   420 WRITE(NOUT,430)
  5491.   430 FORMAT(/,1X,43HENTER THE MODIFY PASSWORD FOR THIS RELATION,/)
  5492.       CALL LXLREC(DUM1,0,LXERR)
  5493.       MPW1 = BLANK
  5494.       IXID1 = LXID(1)
  5495.       IF(IXID1.EQ.K4EOF) GO TO 450
  5496.       IXREC1 = LXWREC(1,1)
  5497.       IF(IXREC1.EQ.K4QUIT) GO TO 998
  5498.       IXLEN = LXLENC(1)
  5499.       IF((IXID1.EQ.KZTEXT).AND.(IXLEN.LE.8)) GO TO 440
  5500.       WRITE(NOUT,8017)
  5501.       GO TO 420
  5502.   440 MPW1 = BLANK
  5503.       CALL LXSREC(1,1,8,MPW1,1)
  5504.   450 IREL(IRCD,52) = RPW1
  5505.       IREL(IRCD,53) = MPW1
  5506. C
  5507. C     REQUEST THE ATTRIBUTE NAMES, TYPES, LENGTHS,
  5508. C     AND WHICH ARE KEYS
  5509. C     3HEND INDICATES THAT ALL ATTRIBUTES FOR THE CURRENT
  5510. C     RELATION HAVE BEEN DEFINED
  5511. C
  5512.       WRITE(NOUT,500)
  5513.   500 FORMAT(/,1X,37HENTER THE ATTRIBUTES OF THIS RELATION,/,
  5514.      1        1X,23HENTER END WHEN COMPLETE,/,
  5515.      2        5X,31HNAME    TYPE    LENGTH (IF > 1),
  5516.      3           18H    "KEY" (IF KEY),/)
  5517.       IATL = 0
  5518.   510 CALL LXLREC(DUM1,0,LXERR)
  5519.       LENR = 1
  5520.       LENC = 1
  5521.       KEY = IBLANK
  5522.       MTYP = 0
  5523.       IXID1 = LXID(1)
  5524.       IF(IXID1.EQ.K4EOF) GO TO 800
  5525. C
  5526. C     CHECK FOR END AND THAT THE ATTRIBUTE NAME IS TEXT
  5527. C
  5528.       IXREC1 = LXWREC(1,1)
  5529.  
  5530.       IF(IXREC1.EQ.K4QUIT) GO TO 998
  5531.       IF(IXREC1.EQ.K4END) GO TO 800
  5532.       IXLEN = LXLENC(1)
  5533.       IF((IXID1.EQ.KZTEXT).AND.(IXLEN.LE.8)) GO TO 520
  5534.       WRITE(NOUT,8007)
  5535.       GO TO 510
  5536. C
  5537. C     CHECK ATTRIBUTE TYPE
  5538. C
  5539.   520 ANAME = BLANK
  5540.       CALL LXSREC(1,1,8,ANAME,1)
  5541.       LPOS = 3
  5542.       IXREC2 = 0
  5543.       IF(EQKEYW(2,KWINT ,7)) IXREC2 = KZINT
  5544.       IF(EQKEYW(2,KWREAL,4)) IXREC2 = KZREAL
  5545.       IF(EQKEYW(2,KWTEXT,4)) GO TO 530
  5546.       IF(EQKEYW(2,KWDOUB,6)) IXREC2 = KZDOUB
  5547.       IF(EQKEYW(2,KWIVEC,4)) IXREC2 = KZIVEC
  5548.       IF(EQKEYW(2,KWRVEC,4)) IXREC2 = KZRVEC
  5549.       IF(EQKEYW(2,KWDVEC,4)) IXREC2 = KZDVEC
  5550.       IF(IXREC2.NE.0) GO TO 550
  5551.       IF(EQKEYW(2,KWIMAT,4)) IXREC2 = KZIMAT
  5552.       IF(EQKEYW(2,KWRMAT,4)) IXREC2 = KZRMAT
  5553.       IF(EQKEYW(2,KWDMAT,4)) IXREC2 = KZDMAT
  5554.       IF(IXREC2.NE.0) GO TO 540
  5555.       WRITE(NOUT,8008)
  5556.       GO TO 510
  5557. C
  5558. C  SET DEFAULT TO 8 CHARACTERS FOR TEXT
  5559. C
  5560.   530 LENR = 8
  5561.       IXREC2 = KZTEXT
  5562.       GO TO 550
  5563.   540 MTYP = 1
  5564.   550 CONTINUE
  5565. C
  5566. C  CHECK ATTRIBUTE LENGTH
  5567. C
  5568.       IXITEM = LXITEM(NUM)
  5569.       IF(IXITEM.EQ.2) GO TO 700
  5570. C
  5571. C  GET THE FIRST DIMENSION (LENGTH)
  5572. C
  5573.       IXREC3 = LXWREC(LPOS,1)
  5574.       IF(IXREC3.EQ.K4KEY) GO TO 670
  5575.       IF(IXREC3.NE.KZVAR) GO TO 610
  5576. C
  5577. C  VARIABLE LENGTH ATTRIBUTE
  5578. C
  5579.       LENR = IXREC3
  5580.       GO TO 620
  5581. C
  5582. C  FIXED LENGTH ATTRIBUTE
  5583. C
  5584.   610 CONTINUE
  5585.       IXID3 = LXID(LPOS)
  5586.       IF(IXID3.NE.KZINT) GO TO 630
  5587.       LENR = LXIREC(LPOS)
  5588.       IF((LENR.LE.0).OR.(LENR.GT.MAXCOL)) GO TO 630
  5589.       IF(MTYP.EQ.1) GO TO 640
  5590.   620 IF(IXITEM.EQ.LPOS) GO TO 700
  5591.       GO TO 670
  5592.   630 WRITE(NOUT,8009)
  5593.       GO TO 510
  5594. C
  5595. C  MATRIX ATTRIBUTE - GET COLUMN DIMENSION
  5596. C
  5597.   640 CONTINUE
  5598.       IXREC3 = LXWREC(LPOS+1,1)
  5599.       IF(IXREC3.NE.KZVAR) GO TO 650
  5600. C
  5601. C  VARIABLE COLUMN DIMENSION
  5602. C
  5603.       LENC = IXREC3
  5604.       GO TO 660
  5605. C
  5606. C  FIXED LENGTH COLUMN DIMENSION
  5607. C
  5608.   650 CONTINUE
  5609.       IXID3 = LXID(LPOS+1)
  5610.       IF(IXID3.NE.KZINT) GO TO 630
  5611.       LENC = LXIREC(LPOS+1)
  5612.       LEN = LENR*LENC
  5613.       IF((LEN.LE.0).OR.(LEN.GT.MAXCOL)) GO TO 630
  5614.   660 IF(IXITEM.EQ.(LPOS+1)) GO TO 700
  5615.   670 CONTINUE
  5616. C
  5617. C     CHECK IF KEY ATTRIBUTE
  5618. C
  5619.       IXRECX = LXWREC(IXITEM,1)
  5620.       IF(IXRECX.NE.K4KEY) GO TO 680
  5621.       KEY = K4KEY
  5622.       GO TO 700
  5623.   680 CONTINUE
  5624.       IF((MTYP.EQ.1).AND.(IXRECX.EQ.KZVAR)) GO TO 700
  5625.       WRITE(NOUT,8018)
  5626.       GO TO 510
  5627. C
  5628. C     STORE THE ATTRIBUTE NAME IN IREL(IRCD,IATL+1) WHERE
  5629. C     IRCD IS THE COUNT OF RELATIONS AND IATL IS THE
  5630. C     COUNT OF ATTRIBUTES FOR THE CURRENT RELATION
  5631. C
  5632.   700 IATL = IATL + 1
  5633.       IF(IATL.LE.50) GO TO 710
  5634.       WRITE(NOUT,8021)
  5635.       IATL = 50
  5636.       GO TO 800
  5637.   710 IREL(IRCD,IATL+1) = ANAME
  5638. C
  5639. C     CHECK IF THIS ATTRIBUTE HAS ALREADY BEEN DEFINED
  5640. C     IF IT HAS CHECK THAT A REDEFINITION HAS NOT OCCURED
  5641. C
  5642.       IF(INTOPT.EQ.K4CRE) GO TO 760
  5643. C
  5644. C  CHECK EXISTING ATTRIBUTES
  5645. C
  5646.       I = LOCATT(ANAME,BLANK)
  5647.       IF(I.NE.0) GO TO 760
  5648. C
  5649. C  EXISTING ATTRIBUTE - GET DEFINITION
  5650. C
  5651.       CALL ATTGET(STATUS)
  5652.       IF(STATUS.NE.0) GO TO 760
  5653.       IF(IXREC2.NE.ATTYPE) WRITE(NOUT,8014) ATTYPE
  5654.       LEN1 = 0
  5655.       LEN2 = 0
  5656.       IF(LENR.EQ.KZVAR) GO TO 720
  5657.       LEN1 = LENR
  5658.       IF(LENC.EQ.KZVAR) GO TO 720
  5659.       LEN2 = LENR
  5660.       IF(ATTYPE.EQ.KZTEXT) LEN2 = ((LENR-1)/CHPWD) + 1
  5661.       IF(MTYP.EQ.1) LEN2 = LENR*LENC
  5662.       CALL TYPER(ATTYPE,DUM1,LEN)
  5663.       IF(LEN.EQ.KZDOUB) LEN2 = 2*LEN2
  5664.       IF(ATTYPE.EQ.KZINT ) LEN1 = 0
  5665.       IF(ATTYPE.EQ.KZREAL) LEN1 = 0
  5666.       IF(ATTYPE.EQ.KZDOUB) LEN1 = 0
  5667.   720 CONTINUE
  5668.       IF(LEN1.NE.ATTCHA) WRITE(NOUT,8015) ATTCHA
  5669.       IF(LEN2.NE.ATTWDS) WRITE(NOUT,8015) ATTWDS
  5670. C
  5671. C  CHECK KEY
  5672. C
  5673.       LEN = K4KEY
  5674.       IF(ATTKEY.EQ.0) LEN = IBLANK
  5675.       IF(KEY.NE.LEN) WRITE(NOUT,8019) IXREC1
  5676.       GO TO 510
  5677.   760 CONTINUE
  5678.       IF(IATC.EQ.0) GO TO 780
  5679. C
  5680. C  CHECK NEW ATTRIBUTES
  5681. C
  5682.       DO 770 J=1,IATC
  5683.       IF(ANAME.NE.IATT(J)) GO TO 770
  5684.       IF(IXREC2.NE.IATTX(J,1)) WRITE(NOUT,8014) IATTX(J,1)
  5685.       IF(LENR.NE.IATTX(J,2)) WRITE(NOUT,8015) IATTX(J,2)
  5686.       IF(LENC.NE.IATTX(J,3)) WRITE(NOUT,8015) IATTX(J,3)
  5687.       IF(KEY.NE.IATTX(J,4)) WRITE(NOUT,8019) IXREC1
  5688.       GO TO 510
  5689.   770 CONTINUE
  5690. C
  5691. C     STORE THE ATTRIBUTE DATA IN IATT
  5692. C       IATT(IATC) = ATTRIBUTE NAME
  5693. C       IATTX(IATC,1) = ATTRIBUTE TYPE
  5694. C       IATTX(IATC,2) = ATTRIBUTE LENGTH - ROW DIMENSION IF MATRIX
  5695. C       IATTX(IATC,3) = COLUMN DIMENSION IF MATRIX
  5696. C       IATTX(IATC,4) = KEY INDICATOR (BLANK OR 3HKEY)
  5697. C       IATC         = COUNT OF UNIQUE ATTRIBUTES
  5698. C
  5699.   780 IATC = IATC + 1
  5700.       IF(IATC.LE.100) GO TO 790
  5701.       WRITE(NOUT,8022)
  5702.       IATC = 100
  5703.       GO TO 800
  5704.   790 IATT(IATC) = ANAME
  5705.       IATTX(IATC,1) = IXREC2
  5706.       IATTX(IATC,2) = LENR
  5707.       IATTX(IATC,3) = LENC
  5708.       IATTX(IATC,4) = KEY
  5709.       GO TO 510
  5710. C
  5711. C     STORE THE NUMBER OF COLUMNS (NO ATTRIBUTES + 1) FOR
  5712. C     THE CURRENT RELATION IN IRELX(IRCD)
  5713. C
  5714.   800 IRELX(IRCD) = IATL + 1
  5715.       IF(IATL.GT.0) GO TO 810
  5716.       WRITE(NOUT,8031) IREL(IRCD,1)
  5717.       IREL(IRCD,1) = BLANK
  5718.       IREL(IRCD,52) = BLANK
  5719.       IREL(IRCD,53) = BLANK
  5720.       IRCD = IRCD - 1
  5721. C
  5722. C     CHECK FOR ADDITIONAL RELATION DEFINITIONS
  5723. C     (BRANCH TO 310 IF YES)
  5724. C
  5725.   810 WRITE(NOUT,820)
  5726.   820 FORMAT(/,1X,45HDO YOU HAVE ADDITIONAL RELATIONS TO DEFINE - ,
  5727.      1           6HY OR N,/)
  5728.       CALL LXLREC(DUM1,0,LXERR)
  5729.       IXID1 = LXID(1)
  5730.       IF(IXID1.EQ.K4EOF) GO TO 830
  5731.       IXREC1 = 0
  5732.       IF(IXID1.EQ.KZINT) IXREC1 = LXIREC(1)
  5733.       IF(IXID1.EQ.KZTEXT) IXREC1 = LXWREC(1,1)
  5734.       IF(IXREC1.EQ.K4QUIT) GO TO 998
  5735.       IF(IXREC1.EQ.K4Y) GO TO 310
  5736.       IF(IXREC1.EQ.K4N) GO TO 830
  5737.       WRITE(NOUT,8010)
  5738.       GO TO 810
  5739. C
  5740. C     DEFINE THE RIM SCHEMA SOURCE FILE
  5741. C
  5742. C     WRITE THE DATABASE NAME AND OWNER
  5743. C
  5744.   830 WRITE(TWO,840) NAMDB,NAMOWN
  5745.   840 FORMAT(2X,7HDEFINE ,A8/2X,6HOWNER ,A8)
  5746. C
  5747. C     WRITE THE LIST OF ELEMENTS (ATTRIBUTES), ELEMENT TYPES,
  5748. C     AND LENGTHS
  5749. C
  5750.       WRITE(TWO,850)
  5751.   850 FORMAT(2X,10HATTRIBUTES)
  5752.       DO 930 J=1,IATC
  5753.       IF(IATTX(J,2).EQ.KZVAR) GO TO 870
  5754.       MTYP = IATTX(J,1)
  5755.       IF((MTYP.EQ.KZIMAT).OR.(MTYP.EQ.KZRMAT).OR.(MTYP.EQ.KZDMAT))
  5756.      1     GO TO 890
  5757.       WRITE(TWO,860) IATT(J),IATTX(J,1),IATTX(J,2),IATTX(J,4)
  5758.   860 FORMAT(2X,A8,2X,A4,2X,I4,6X,A3)
  5759.       GO TO 930
  5760.   870 WRITE(TWO,880) IATT(J),IATTX(J,1),IATTX(J,2),IATTX(J,4)
  5761.   880 FORMAT(2X,A8,2X,A4,3X,A3,6X,A3)
  5762.       GO TO 930
  5763. C
  5764. C MATRIX
  5765. C
  5766.   890 IF(IATTX(J,3).EQ.KZVAR) GO TO 910
  5767.       WRITE(TWO,900) IATT(J),IATTX(J,1),IATTX(J,2),IATTX(J,3),IATTX(J,4)
  5768.   900 FORMAT(2X,A8,2X,A4,2X,I4,I4,2X,A3)
  5769.       GO TO 930
  5770.   910 WRITE(TWO,920) IATT(J),IATTX(J,1),IATTX(J,2),IATTX(J,3),IATTX(J,4)
  5771.   920 FORMAT(2X,A8,2X,A4,2X,I4,1X,A3,2X,A3)
  5772.   930 CONTINUE
  5773. C
  5774. C     WRITE THE RELATIONS - IF CONTINUATION IS REQUIRED
  5775. C     A + IS INSERTED AT THE END OF THE LINE
  5776. C
  5777.       IF(IRCD.EQ.0) GO TO 1040
  5778.       WRITE(TWO,950)
  5779.   950 FORMAT(2X,9HRELATIONS)
  5780.       DO 1000 J=1,IRCD
  5781.       NUM = IRELX(J) - 1
  5782.       K1 = 1
  5783.       K2 = 4
  5784.   960 IEND = IBLANK
  5785.       IF(NUM.GT.4) IEND = K4PLUS
  5786.       IF(NUM.LT.4) K2 = NUM
  5787.       IF(K1.EQ.1)WRITE(TWO,970)IREL(J,1),(IREL(J,K1+K),K=1,K2),IEND
  5788.       IF(K1.GT.1)WRITE(TWO,980) (IREL(J,K1+K),K=1,K2),IEND
  5789.   970 FORMAT(2X,A8,5H WITH,4(2X,A8),2X,A1)
  5790.   980 FORMAT(15X,4(2X,A8),2X,A1)
  5791.       IF(NUM.LE.4) GO TO 1000
  5792.       K1 = K1 + 4
  5793.       NUM = NUM - 4
  5794.       GO TO 960
  5795.  1000 CONTINUE
  5796. C
  5797. C     WRITE THE PASSWORDS
  5798. C
  5799.       WRITE(TWO,1010)
  5800.  1010 FORMAT(2X,9HPASSWORDS)
  5801.       DO 1030 J=1,IRCD
  5802.       RPW1 = IREL(J,52)
  5803.       MPW1 = IREL(J,53)
  5804.       IF(RPW1.NE.BLANK) WRITE(TWO,1020) IREL(J,1),RPW1
  5805.       IF(MPW1.NE.BLANK) WRITE(TWO,1021) IREL(J,1),MPW1
  5806.  1020 FORMAT(2X,4HREAD,14H PASSWORD FOR ,A8,4H IS ,A8)
  5807.  1021 FORMAT(2X,6HMODIFY,14H PASSWORD FOR ,A8,4H IS ,A8)
  5808.  1030 CONTINUE
  5809. C
  5810. C     WRITE THE END RECORD
  5811. C
  5812.  1040 CONTINUE
  5813.       WRITE(TWO,1050)
  5814.  1050 FORMAT(2X,3HEND)
  5815. C
  5816.  1110 CONTINUE
  5817.       IF(INTOPT.EQ.K4CRE) GO TO 999
  5818.       IF(NAMDB.EQ.DBNAME) GO TO 1120
  5819.       WRITE(NOUT,8027) NAMDB
  5820.       GO TO 998
  5821.  1120 IF(NAMOWN.EQ.OWNER) GO TO 999
  5822.       WRITE(NOUT,8030)
  5823.       GO TO 998
  5824. C
  5825. C  RETURN AND CALL CSC TO COMPILE THE SCHEMA
  5826. C
  5827.   998 CONTINUE
  5828.       INTOPT = 0
  5829.   999 CONTINUE
  5830.       REWIND TWO
  5831. C
  5832. C  CLOSE THE SCHEMA SOURCE FILE
  5833. C
  5834.       CLOSE(TWO)
  5835.       RETURN
  5836. C
  5837. C     ERROR MESSAGES ---------------------------------------
  5838. C
  5839.  8002 FORMAT(/,1X,39H-ERROR- THE DATABASE OWNER MUST BE 1-8 ,
  5840.      1           23HALPHANUMERIC CHARACTERS,/)
  5841.  8006 FORMAT(/,1X,36H-ERROR- RELATION NAMES MUST BE TEXT ,
  5842.      1           16H(1-8 CHARACTERS),/)
  5843.  8007 FORMAT(/,1X,37H-ERROR- ATTRIBUTE NAMES MUST BE TEXT ,
  5844.      1           16H(1-8 CHARACTERS),/,9X,17HREENTER LAST LINE,/)
  5845.  8008 FORMAT(/,1X,43H-ERROR- ATTRIBUTE TYPES MUST BE ONE OF THE ,
  5846.      1           12HFOLLOWING --,/,9X,21HINT,REAL,TEXT,DOUBLE,,
  5847.      2           32HIVEC,RVEC,DVEC,IMAT,RMAT OR DMAT,/,
  5848.      3            9X,17HREENTER LAST LINE,/)
  5849.  8009 FORMAT(/,1X,44H-ERROR- THE NUMBER OF WORDS IN AN ATTRIBUTE ,
  5850.      1           41HMUST BE A POSITIVE INTEGER LESS THAN 1023,/,
  5851.      2        9X,17HREENTER LAST LINE,/)
  5852.  8010 FORMAT(/,1X,41H-ERROR- EITHER "Y" OR "N" MUST BE ENTERED,/)
  5853.  8014 FORMAT(/,1X,34H-ERROR- ATTRIBUTE TYPE REDEFINED (,A4,
  5854.      1           19H TYPE WILL BE USED),/)
  5855.  8015 FORMAT(/,1X,44H-ERROR- ATTRIBUTE LENGTH REDEFINED (LENGTH =,
  5856.      1             I3,14H WILL BE USED),/)
  5857.  8017 FORMAT(/,1X,39H-ERROR- THE RELATION PASSWORDS MUST BE ,
  5858.      1           23HALPHANUMERIC CHARACTERS,/)
  5859.  8018 FORMAT(/,1X,32H-ERROR- THE KEY ENTRY IS ILLEGAL,/,
  5860.      1        9X,17HREENTER LAST LINE,/)
  5861.  8019 FORMAT(/,1X,48H-ERROR- KEY SPECIFICATION CHANGED FOR ATTRIBUTE ,
  5862.      1           A10,/,9X,27HORIGINAL SPECIFICATION USED,/)
  5863.  8020 FORMAT(/,1X,41H-ERROR- 25 RELATIONS IS THE CURRENT LIMIT,/,
  5864.      1        9X,30HRELATION PROCESSING TERMINATED,/)
  5865.  8021 FORMAT(/,1X,42H-ERROR- 50 ATTRIBUTES IS THE CURRENT LIMIT,/,
  5866.      1        9X,30HRELATION PROCESSING TERMINATED,/)
  5867.  8022 FORMAT(/,1X,50H-ERROR- 100 UNIQUE ATTRIBUTES IS THE CURRENT LIMIT,
  5868.      1       /,9X,30HRELATION PROCESSING TERMINATED,/)
  5869.  8027 FORMAT(/,1X,26H-ERROR- THE DATABASE NAME ,A6,10H DOES NOT ,
  5870.      1           27HMATCH THE DATABASE CONTENTS,/)
  5871.  8028 FORMAT(/,1X,35H-ERROR- UNAUTHORIZED ACCESS TO THE ,
  5872.      1           15HDATABASE SCHEMA,/,/,1X,17HENTER AUTHORIZED ,
  5873.      2           15HOWNER OR "QUIT",/)
  5874.  8029 FORMAT(/,1X,17H-ERROR- RELATION ,A10,15H ALREADY EXISTS,/)
  5875.  8030 FORMAT(/,1X,35H-ERROR- UNAUTHORIZED ACCESS TO THE ,
  5876.      1           15HDATABASE SCHEMA,/)
  5877.  8031 FORMAT(/,1X,19H-WARNING- RELATION ,A10,15H DOES NOT HAVE ,
  5878.      X   20HANY LEGAL ATTRIBUTES,/)
  5879. C
  5880.       END
  5881.       SUBROUTINE INTLOD(INTOPT)
  5882.         Include TEXT.BLK
  5883.         Include FILES.BLK
  5884.         Include RMATTS.BLK
  5885.         Include CONST4.BLK
  5886.         Include CONST8.BLK
  5887.         Include RMKEYW.BLK
  5888.         Include MISC.BLK
  5889.         Include FLAGS.BLK
  5890.         Include TUPLER.BLK
  5891.         Include TUPLEA.BLK
  5892.         Include DCLAR1.BLK
  5893.         Include DCLAR3.BLK
  5894.       INTEGER STATUS
  5895.       LOGICAL EQ,NE
  5896.       LOGICAL EQKEYW
  5897.       IF(INTOPT.EQ.0) GO TO 90
  5898. C
  5899. C  ASK IF MORE RELATIONS ARE TO BE LOADED
  5900. C
  5901.    10 WRITE(NOUT,20)
  5902.    20 FORMAT(/,50H DO YOU HAVE ADDITIONAL RELATIONS TO LOAD - Y OR N,/)
  5903.       CALL LXLREC(DUM1,0,LXERR)
  5904.       IDX = LXID(1)
  5905.       IF(IDX.EQ.K4EOF) GO TO 80
  5906.       IF(EQKEYW(1,KWQUIT,4)) GO TO 997
  5907.       IF(EQKEYW(1,KWEXIT,4)) GO TO 998
  5908.       IRECX = IBLANK
  5909.       CALL LXSREC(1,1,1,IRECX,1)
  5910.       IF(IRECX.EQ.K4N) GO TO 80
  5911.       IF(IRECX.EQ.K4Y) GO TO 90
  5912.       WRITE(NOUT,8004)
  5913.       GO TO 10
  5914. C
  5915. C  NO MORE RELATIONS TO LOAD
  5916. C
  5917.    80 CONTINUE
  5918.       INTOPT = K4QUE
  5919.       GO TO 999
  5920. C
  5921. C  LOAD A RELATION
  5922. C
  5923.    90 CONTINUE
  5924. C
  5925. C  CHECK FOR VALID RELATIONS
  5926. C
  5927.       I = LOCREL(BLANK)
  5928.       IF(I.EQ.0) GO TO 200
  5929.       WRITE(NOUT,100)
  5930.   100 FORMAT(32H -WARNING- RELATION TABLES EMPTY ,/)
  5931.       INTOPT = K4EXIT
  5932.       GO TO 999
  5933. C
  5934. C  DISPLAY AVAILABLE RELATIONS
  5935. C
  5936.   200 CONTINUE
  5937.       WRITE(NOUT,210)
  5938.   210 FORMAT(/,33H SELECT THE RELATION TO BE LOADED)
  5939.       K = 0
  5940.   220 CALL RELGET(STATUS)
  5941.       IF(STATUS.NE.0) GO TO 250
  5942.       IF(EQ(NAME,K8RDT)) GO TO 220
  5943.       IF(EQ(NAME,K8RRC)) GO TO 220
  5944.       K = K + 1
  5945.       WRITE(NOUT,230) K,NAME
  5946.   230 FORMAT(4X,I2,2H) ,A8)
  5947.       GO TO 220
  5948. C
  5949. C  GET THE USERS SELECTION
  5950. C
  5951.   250 CONTINUE
  5952.       CALL LXLREC(DUM1,0,LXERR)
  5953.       IDX = LXID(1)
  5954.       IF(IDX.EQ.K4EOF) GO TO 10
  5955.       IRECX = LXIREC(1)
  5956.       IF(EQKEYW(1,KWQUIT,4)) GO TO 997
  5957.       IF(EQKEYW(1,KWEXIT,4)) GO TO 998
  5958.       IF((IRECX.GE.1).AND.(IRECX.LE.K)) GO TO 260
  5959.       WRITE(NOUT,8001) K
  5960.       GO TO 250
  5961. C
  5962. C  LOCATE THE REQUESTED SELECTION
  5963. C
  5964.   260 CONTINUE
  5965.       I = LOCREL(BLANK)
  5966.       K = 0
  5967.   270 CALL RELGET(STATUS)
  5968.       IF(STATUS.NE.0) GO TO 998
  5969.       IF(EQ(NAME,K8RDT)) GO TO 270
  5970.       IF(EQ(NAME,K8RRC)) GO TO 270
  5971.       K = K + 1
  5972.       IF(IRECX.EQ.K) GO TO 300
  5973.       GO TO 270
  5974. C
  5975. C  CHECK PERMISSION TO MODIFY THE RELATION
  5976. C
  5977.   300 CONTINUE
  5978.       IF(EQ(MPW,NONE)) GO TO 360
  5979.       IF(EQ(MPW,USERID)) GO TO 360
  5980.       IF(EQ(USERID,OWNER)) GO TO 360
  5981.       WRITE(NOUT,310)
  5982.   310 FORMAT(/,44H ENTER THE MODIFY PASSWORD FOR THIS RELATION,/)
  5983.       CALL LXLREC(DUM1,0,LXERR)
  5984.       MPW1 = NONE
  5985.       IDX = LXID(1)
  5986.       IF(IDX.EQ.K4EOF) GO TO 350
  5987.       IF(EQKEYW(1,KWQUIT,4)) GO TO 997
  5988.       IF(EQKEYW(1,KWEXIT,4)) GO TO 998
  5989.       IF((IDX.EQ.KZTEXT).AND.(LXLENC(1).LE.8)) GO TO 340
  5990.       WRITE(NOUT,8002)
  5991.       GO TO 300
  5992. C
  5993. C  CHECK THE PASSWORD
  5994. C
  5995.   340 CONTINUE
  5996.       MPW1 = BLANK
  5997.       CALL LXSREC(1,1,8,MPW1,1)
  5998.   350 CONTINUE
  5999.       IF(EQ(MPW1,MPW)) GO TO 355
  6000.       IF(EQ(MPW1,OWNER)) GO TO 355
  6001.       WRITE(NOUT,8003) NAME
  6002.       GO TO 10
  6003. C
  6004. C  GET THE ATTRIBUTES FOR THIS RELATION
  6005. C
  6006.   355 CONTINUE
  6007.       USERID = MPW1
  6008.   360 CONTINUE
  6009.       I = LOCATT(BLANK,NAME)
  6010.       WRITE(NOUT,370)
  6011.   370 FORMAT(/,44H ENTER THE ATTRIBUTE VALUES IN THE SPECIFIED,
  6012.      X          9H SEQUENCE,/,24H ENTER END WHEN COMPLETE,/)
  6013.       NUM = 0
  6014.   400 CALL ATTGET(STATUS)
  6015.       IF(STATUS.NE.0) GO TO 450
  6016.       NUM = NUM + 1
  6017.       NAMES(NUM) = ATTNAM
  6018.       IF(NUM.LT.8) GO TO 400
  6019.       WRITE(NOUT,410) (NAMES(J),J=1,7)
  6020.   410 FORMAT(7(1X,A8),2X,1H+)
  6021.       NUM = 1
  6022.       NAMES(1) = NAMES(8)
  6023.       GO TO 400
  6024. C
  6025. C  PRINT LAST LINE OF ATTRIBUTES
  6026. C
  6027.   450 WRITE(NOUT,460) (NAMES(J),J=1,NUM)
  6028.   460 FORMAT(7(1X,A8))
  6029. C
  6030. C  GO GET THE DATA - CALL DBLOAD
  6031. C
  6032.       NAMES(1) = BLANK
  6033.       NAMES(2) = BLANK
  6034.       CALL STRMOV(KWLOAD,1,4,NAMES,1)
  6035.       CALL STRMOV(NAME,1,8,NAMES,6)
  6036.       CALL LXLREC(NAMES,16,LXERR)
  6037.       INTOPT = K4LOD
  6038.       GO TO 999
  6039. C
  6040. C  QUIT
  6041. C
  6042.   997 CONTINUE
  6043.       INTOPT = K4QUIT
  6044.       GO TO 999
  6045. C
  6046. C  EXIT
  6047. C
  6048.   998 CONTINUE
  6049.       INTOPT = K4EXIT
  6050.       GO TO 999
  6051. C
  6052.   999 CONTINUE
  6053.       RETURN
  6054. C
  6055. C  ERROR MESSAGES -----
  6056. C
  6057.  8001 FORMAT(/,37H -ERROR- AN INTEGER IN THE RANGE 1 TO,I3,
  6058.      X         16H MUST BE ENTERED,/)
  6059.  8002 FORMAT(/,43H -ERROR- PASSWORDS MUST BE 1-8 ALPHANUMERIC,
  6060.      X         11H CHARACTERS,/)
  6061.  8003 FORMAT(/,41H -ERROR- UNAUTHORIZED ACCESS TO RELATION ,A8,/)
  6062.  8004 FORMAT(/,42H -ERROR- EITHER "Y" OR "N" MUST BE ENTERED,/)
  6063.       END
  6064.       INTEGER FUNCTION ISCAN(STR1,IC1,LC1,STR2,IC2,LC2,J1)
  6065.         Include TEXT.BLK
  6066. C
  6067. C  PURPOSE:   LOCATE THE FIRST CHARACTER IN STR1 WHICH DOES
  6068. C             MATCH THE CHARACTERS IN STR2
  6069. C
  6070. C  PARAMETERS:
  6071. C     STR1----FIRST HOLLERITH STRING
  6072. C     IC1-----STARTING CHARACTER IN STR1 TO START THE SCAN
  6073. C     LC1-----LENGTH OF STR1
  6074. C     STR2----SECOND HOLLERITH STRING
  6075. C     IC2-----STARTING CHARACTER IN STR2
  6076. C     LC2-----LENGTH OF STR2
  6077. C     J1------CHARACTER POSITION IN STR1 OF FIRST MATCH
  6078. C             0 IF ALL NO MATCH
  6079. C     ISCAN---CHARACTER POSITION IN STR2 OF FIRST MATCH
  6080. C             0 IF ALL NO MATCH
  6081. C
  6082.       CHARACTER*1 STR1(1)
  6083.       CHARACTER*1 STR2(1)
  6084. C
  6085. C  IF LC1 IS NEGATIVE THE SCAN IS RIGHT TO LEFT.
  6086. C
  6087.       INC = 1
  6088.       IF(LC1.LT.0) INC = -1
  6089.       LC = INC * LC1
  6090.       I1 = IC1
  6091. C
  6092. C  SCAN STR1.
  6093. C
  6094.       DO 200 I=1,LC
  6095.       I2 = IC2 - 1
  6096.       DO 100 J=1,LC2
  6097.       I2 = I2 + 1
  6098.       IF(STR1(I1).EQ.STR2(I2)) GO TO 300
  6099.   100 CONTINUE
  6100.       I1 = I1 + INC
  6101.   200 CONTINUE
  6102. C
  6103. C  NO CHARACTERS MATCH.
  6104. C
  6105.       ISCAN = 0
  6106.       J1 = 0
  6107.       RETURN
  6108. C
  6109. C  WE FOUND A MATCHING CHARACTER.
  6110. C
  6111.   300 CONTINUE
  6112.       ISCAN = I2
  6113.       J1 = I1
  6114.       RETURN
  6115.       END
  6116.       SUBROUTINE ISECT(RNAME1,RNAME3,MATN3,NCOL3,NATT3,PTABLE,
  6117.      XKEYCOL,KEYTYP)
  6118.         Include TEXT.BLK
  6119. C
  6120. C  THIS ROUTINE PERFORMS THE ACTUAL INTERSECT BETWEEN
  6121. C  RELATION 1 AND 2 FORMING 3
  6122. C
  6123. C  PARAMETERS:
  6124. C         NAME1---NAME OF THE FIRST RELATION
  6125. C         MATN3---DATA TUPLE FOR RELATION 3
  6126. C         NCOL3---NUMBER OF FIXED LENGTH COLUMNS IN MATN3
  6127. C         NATT3---NUMBER OF ATTRIBUTES IN MATN3
  6128. C         PTABLE--POINTER TABLE FOR THIS INTERSECT
  6129. C         KEYCOL--COLUMN OF MATN2 USED FOR SUPPLYING KEY VALUES
  6130. C         KEYTYP--ATTRIBUTE TYPE OF MATN1 USED FOR KEY VALUES
  6131.         Include MISC.BLK
  6132.         Include RMATTS.BLK
  6133.         Include FILES.BLK
  6134.         Include TUPLER.BLK
  6135.         Include RIMPTR.BLK
  6136.         Include RIMCOM.BLK
  6137.         Include BUFFER.BLK
  6138.         Include WHCOM.BLK
  6139.         Include DCLAR1.BLK
  6140.       DIMENSION MATN3(1)
  6141.       INTEGER PTABLE(7,1)
  6142.       INTEGER ATTLEN
  6143.       INTEGER ENDCOL
  6144. C
  6145. C  INITIALIZE THE MATRIX POINTERS.
  6146. C
  6147.       IERR = 0
  6148.       IDST = 0
  6149.       IDNEW = 0
  6150.       IDCUR = NID
  6151. C
  6152. C  GET THE PARAMETERS FOR THE FIRST MATRIX.
  6153. C
  6154.       I = LOCREL(RNAME1)
  6155.       IDM1 = NID
  6156.       NSP = 0
  6157.       IF(KSTRT.NE.0) NSP = 2
  6158.       NTUP3 = 0
  6159. C
  6160. C  SEQUENCE THROUGH MATN2.
  6161. C
  6162.   100 CONTINUE
  6163.       IF(IDCUR.EQ.0) GO TO 1000
  6164.       CALL ITOH(N1,N2,IDCUR)
  6165.       IF(N2.EQ.0) GO TO 1000
  6166.       CALL GETDAT(2,IDCUR,MATN2,NCOL2)
  6167.       IF(IDCUR.LT.0) GO TO 1000
  6168. C
  6169. C  MOVE THE COMPARISON VALUE INTO THE WHCOM ARRAYS.
  6170. C
  6171.       CALL ITOH(NCHAR,NWORDS,KATTL(1))
  6172.       IP = MATN2 + KEYCOL - 1
  6173.       IF(NWORDS.NE.0) GO TO 110
  6174. C
  6175. C  SPECIAL GYRATIONS FOR VARIABLE LENGTH STUFF.
  6176. C
  6177.       IP2 = BUFFER(IP)
  6178.       IP = MATN2 + IP2 + 1
  6179.   110 CONTINUE
  6180.       WHRVAL(1) = BUFFER(IP)
  6181.       NID = IDM1
  6182.       NS = NSP
  6183.   200 CONTINUE
  6184.       CALL RMLOOK(MATN1,1,1,NCOL1)
  6185.       IF(RMSTAT.NE.0) GO TO 100
  6186. C
  6187. C  CHECK TO SEE IF THE ATTRIBUTES MATCH.
  6188. C
  6189.       K = 1
  6190.   300 CONTINUE
  6191.       CALL PTRS(IPT1,IPT2,K,NATT3,PTABLE,LEN,ITYPE)
  6192. C
  6193. C  IF K IS 0 WE HAVE LOOKED AT ALL THE COMMON ATTRIBUTES.
  6194. C
  6195.       IF(K.EQ.0) GO TO 400
  6196.       I1 = MATN1 + IPT1 - 1
  6197.       I2 = MATN2 + IPT2 - 1
  6198.       IF(LEN.EQ.0) GO TO 320
  6199.       DO 310 I=1,LEN
  6200.       IF(BUFFER(I1).NE.BUFFER(I2)) GO TO 200
  6201.       I1 = I1 + 1
  6202.       I2 = I2 + 1
  6203.   310 CONTINUE
  6204. C
  6205. C  A MATCH. LOOK AT MORE ATTRIBUTES.
  6206. C
  6207.       GO TO 300
  6208. C
  6209. C  VARIABLE LENGTH ATTRIBUTE PROCESSING.
  6210. C
  6211.   320 CONTINUE
  6212.       IPT1 = BUFFER(I1)
  6213.       IPT2 = BUFFER(I2)
  6214.       I1 = MATN1 + IPT1 - 1
  6215.       I2 = MATN2 + IPT2 - 1
  6216.       IF(BUFFER(I1).NE.BUFFER(I2)) GO TO 200
  6217.       LEN = BUFFER(I1)
  6218.       I1 = I1 + 2
  6219.       I2 = I2 + 2
  6220.       DO 340 I=1,LEN
  6221.       IF(BUFFER(I1).NE.BUFFER(I2)) GO TO 200
  6222.       I1 = I1 + 1
  6223.       I2 = I2 + 1
  6224.   340 CONTINUE
  6225.       GO TO 300
  6226. C
  6227. C  OKAY -- NOW LOAD THE DATA.
  6228. C
  6229.   400 CONTINUE
  6230.       ENDCOL = NCOL3
  6231.       DO 900 KLM=1,NATT3
  6232.       KOL1 = PTABLE(3,KLM)
  6233.       KOL2 = PTABLE(4,KLM)
  6234.       KOL3 = PTABLE(5,KLM)
  6235.       ATTLEN = PTABLE(6,KLM)
  6236.       CALL ITOH(NCHAR,NWORDS,ATTLEN)
  6237.       IF(NWORDS.EQ.0) GO TO 700
  6238.       DO 600 I=1,NWORDS
  6239.       IF(KOL1.EQ.0) GO TO 500
  6240. C
  6241. C  LOAD THE ATTRIBUTE FROM MATN1.
  6242. C
  6243.       I1 = MATN1 + KOL1 - 1
  6244.       MATN3(KOL3) = BUFFER(I1)
  6245.       KOL3 = KOL3 + 1
  6246.       KOL1 = KOL1 + 1
  6247.       GO TO 600
  6248.   500 CONTINUE
  6249. C
  6250. C  LOAD THE ATTRIBUTE FROM MATN2.
  6251. C
  6252.       I2 = MATN2 + KOL2 - 1
  6253.       MATN3(KOL3) = BUFFER(I2)
  6254.       KOL3 = KOL3 + 1
  6255.       KOL2 = KOL2 + 1
  6256.   600 CONTINUE
  6257.       GO TO 900
  6258.   700 CONTINUE
  6259.       ENDCOL = ENDCOL + 1
  6260.       MATN3(KOL3) = ENDCOL
  6261.       IF(KOL1.EQ.0) GO TO 710
  6262. C
  6263. C  USE POINTERS FROM MATN1.
  6264. C
  6265.       I1 = MATN1 + KOL1 - 1
  6266.       KOL1 = BUFFER(I1)
  6267.       I2 = MATN1 + KOL1 - 1
  6268.       NWORDS = BUFFER(I2)
  6269.       GO TO 720
  6270.   710 CONTINUE
  6271. C
  6272. C  USE POINTERS FROM MATN2.
  6273. C
  6274.       I2 = MATN2 + KOL2 - 1
  6275.       KOL2 = BUFFER(I2)
  6276.       I2 = MATN2 + KOL2 - 1
  6277.       NWORDS = BUFFER(I2)
  6278.   720 CONTINUE
  6279. C
  6280. C  LOAD UP THE VALUES.
  6281. C
  6282.       IF((ENDCOL+NWORDS+1).GT.MAXCOL) GO TO 950
  6283.       MATN3(ENDCOL) = NWORDS
  6284.       NWORDS = NWORDS + 1
  6285.       DO 800 I=1,NWORDS
  6286.       ENDCOL = ENDCOL + 1
  6287.       I2 = I2 + 1
  6288.       MATN3(ENDCOL) = BUFFER(I2)
  6289.   800 CONTINUE
  6290.   900 CONTINUE
  6291.       CALL ADDDAT(3,IDNEW,MATN3,ENDCOL)
  6292.       IF(IDST.EQ.0) IDST = IDNEW
  6293.       NTUP3 = NTUP3 + 1
  6294. C
  6295. C  LOOK FOR MORE IN MATN1.
  6296. C
  6297.       GO TO 200
  6298. C
  6299. C  TUPLE LENGTH EXCEEDS MAXCOL
  6300. C
  6301.   950 CONTINUE
  6302.       IERR = 1
  6303.       WRITE(NOUT,960) MAXCOL
  6304.   960 FORMAT(36H -ERROR- RELATION ROW LENGTH EXCEEDS,I5)
  6305. C
  6306. C  ALL DONE.
  6307. C
  6308.  1000 CONTINUE
  6309.       I = LOCREL(RNAME3)
  6310.       CALL RELGET(ISTAT)
  6311.       RSTART = IDST
  6312.       REND = IDNEW
  6313.       NTUPLE = NTUP3
  6314.       CALL RELPUT
  6315.       NUM = NTUP3
  6316.       IF(IERR.EQ.0) WRITE(NOUT,9000) NUM
  6317.  9000 FORMAT(32H SUCCESSFUL INTERSECT OPERATION ,
  6318.      XI6,15H ROWS GENERATED)
  6319. C
  6320. C  RETURN
  6321. C
  6322.       RETURN
  6323.       END
  6324.       SUBROUTINE ISREL
  6325.         Include TEXT.BLK
  6326. C
  6327. C  THIS ROUTINE FINDS THE INTERSECTION OF TWO RELATIONS BASED UPON
  6328. C  ATTRIBUTES.  THE RESULT FROM THIS PROCESS IS A PHYSICAL
  6329. C  RELATION WHICH HAS TUPLES CONTRUCTED FROM BOTH RELATIONS
  6330. C  WHERE COMMON ATTRIBUTES MATCH.
  6331. C
  6332. C  THE SYNTAX FOR THE INTERSECT COMMAND IS:
  6333. C
  6334. C   INTERSECT REL1 WITH REL2 FORMING REL3 [USING ATTR1 ATTR2...ATTR-N]
  6335. C
  6336.         Include RMATTS.BLK
  6337.         Include RMKEYW.BLK
  6338.         Include CONST4.BLK
  6339.         Include FLAGS.BLK
  6340.         Include RIMPTR.BLK
  6341.         Include RIMCOM.BLK
  6342.         Include TUPLER.BLK
  6343.         Include TUPLEA.BLK
  6344.         Include FILES.BLK
  6345.         Include BUFFER.BLK
  6346.         Include WHCOM.BLK
  6347.         Include MISC.BLK
  6348. C
  6349.       INTEGER PTABLE
  6350.       LOGICAL EQ
  6351.       LOGICAL NE
  6352.       LOGICAL EQKEYW
  6353.         Include DCLAR1.BLK
  6354.         Include DCLAR3.BLK
  6355. C
  6356. C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
  6357. C
  6358.       CALL RMDBLK(DBNAME)
  6359.       IF(RMSTAT.EQ.0) GO TO 50
  6360.       CALL WARN(RMSTAT,DBNAME,0)
  6361.       GO TO 9999
  6362. C
  6363. C  LOCAL ARRAYS AND VARIABLES :
  6364. C
  6365. C  PTABLE (MATRIX 10) USED TO CONTROL POINTERS
  6366. C        ROWS1,2 -- ATTRIBUTE NAME
  6367. C        ROW3 -- ATTRIBUTE LOCATION IN RELATION 1
  6368. C        ROW4 -- ATTRIBUTE LOCATION IN RELATION 2
  6369. C        ROW5 -- ATTRIBUTE LOCATION IN RELATION 3
  6370. C        ROW6 -- LENGTH IN WORDS
  6371. C        ROW7 -- ATTRIBUTE TYPE
  6372. C
  6373. C  EDIT COMMAND SYNTAX
  6374. C
  6375.    50 CONTINUE
  6376.       CALL BLKCLN
  6377.       NS = 0
  6378.       IF(.NOT.EQKEYW(3,KWWITH,4)) GO TO 9900
  6379.       IF(.NOT.EQKEYW(5,KWFORM,7)) GO TO 9900
  6380.       ITEMS = LXITEM(IDUMMY)
  6381.       IF(ITEMS.GT.6 .AND. .NOT.EQKEYW(7,KWUSIN,5)) GO TO 9900
  6382. C
  6383. C  KEYWORD SYNTAX OKAY
  6384. C
  6385.       RNAME1 = BLANK
  6386.       CALL LXSREC(2,1,8,RNAME1,1)
  6387.       I = LOCREL(RNAME1)
  6388.       IF(I.EQ.0) GO TO 100
  6389. C
  6390. C  MISSING FIRST RELATION.
  6391. C
  6392.       CALL WARN(1,RNAME1,0)
  6393.       GO TO 9999
  6394.   100 CONTINUE
  6395. C
  6396. C  SAVE DATA ABOUT RELATION 1
  6397. C
  6398.       I1 = LOCPRM(RNAME1,1)
  6399.       IF(I1.EQ.0) GO TO 110
  6400.       CALL WARN(9,RNAME1,0)
  6401.       GO TO 9999
  6402.   110 CONTINUE
  6403.       NCOL1 = NCOL
  6404.       NATT1 = NATT
  6405.       RPW1 = RPW
  6406.       MPW1 = MPW
  6407.       RNAME2 = BLANK
  6408.       CALL LXSREC(4,1,8,RNAME2,1)
  6409.       I = LOCREL(RNAME2)
  6410.       IF(I.EQ.0) GO TO 200
  6411. C
  6412. C  MISSING SECOND RELATION.
  6413. C
  6414.       CALL WARN(1,RNAME2,0)
  6415.       GO TO 9999
  6416.   200 CONTINUE
  6417. C
  6418. C  SAVE DATA ABOUT RELATION 2
  6419. C
  6420.       I2 = LOCPRM(RNAME2,1)
  6421.       IF(I2.EQ.0) GO TO 210
  6422.       CALL WARN(9,RNAME2,0)
  6423.       GO TO 9999
  6424.   210 CONTINUE
  6425.       NCOL2 = NCOL
  6426.       NATT2 = NATT
  6427.       RPW2 = RPW
  6428.       MPW2 = MPW
  6429. C
  6430. C  CHECK FOR LEGAL RNAME3
  6431. C
  6432.       IF((LXLENC(6).GE.1).AND.(LXLENC(6).LE.8)) GO TO 250
  6433.       CALL WARN(7,KWRELA,BLANK)
  6434.       GO TO 9999
  6435.   250 CONTINUE
  6436. C
  6437. C  CHECK FOR DUPLICATE RELATION 3
  6438. C
  6439.       RNAME3 = BLANK
  6440.       CALL LXSREC(6,1,8,RNAME3,1)
  6441.       I = LOCREL(RNAME3)
  6442.       IF(I.NE.0) GO TO 300
  6443. C
  6444. C  ERROR
  6445. C
  6446.       WRITE(NOUT,9000)
  6447.  9000 FORMAT(55H -ERROR- RESULTANT RELATION DOES NOT HAVE A UNIQUE NAME)
  6448.       GO TO 9999
  6449. C
  6450. C  CHECK USER READ SECURITY
  6451. C
  6452.   300 CONTINUE
  6453.       IF((I1.NE.0).OR.(I2.NE.0)) GO TO 9999
  6454. C
  6455. C  RELATION NAMES OKAY -- CHECK THE ATTRIBUTES
  6456. C
  6457. C  SET UP PTABLE IN MATRIX POSITION 10
  6458. C
  6459.       CALL BLKDEF(10,7,NATT1+NATT2)
  6460.       PTABLE = BLKLOC(10)
  6461.       NATT3 = 0
  6462.       IF(ITEMS.EQ.6) GO TO 500
  6463. C
  6464. C  INTERSECT ON SOME OF THE ATTRIBUTES
  6465. C
  6466.       IF(ITEMS-7.LE.NATT1+NATT2) GO TO 350
  6467.       WRITE(NOUT,9001)
  6468.  9001 FORMAT(38H -ERROR- TOO MANY ATTRIBUTES SPECIFIED)
  6469.       GO TO 9999
  6470.   350 CONTINUE
  6471.       IJ = 1
  6472.       DO 400 I=8,ITEMS
  6473. C
  6474. C  RETRIEVE ATTRIBUTE LENGTH FOR OLD ATTRIBUTE
  6475. C
  6476. C
  6477. C  SEE IF IT FROM RELATION 1.
  6478. C
  6479.       ANAME = BLANK
  6480.       CALL LXSREC(I,1,8,ANAME,1)
  6481.       ICHK1 = LOCATT(ANAME,RNAME1)
  6482. C
  6483. C  SEE IF IT IS FROM RELATION 2.
  6484. C
  6485.       ICHK2 = LOCATT(ANAME,RNAME2)
  6486.       IF((ICHK1.NE.0).AND.(ICHK2.NE.0)) GO TO 450
  6487. C
  6488. C  ATTRIBUTE IS OKAY -- SET UP PTABLE
  6489. C
  6490.       IF(ICHK1.EQ.0) ICHK1 = LOCATT(ANAME,RNAME1)
  6491.       IF(ICHK2.EQ.0) ICHK2 = LOCATT(ANAME,RNAME2)
  6492.       CALL ATTGET(ISTAT)
  6493.       NATT3 = NATT3 + 1
  6494.       BUFFER(PTABLE) = LXWREC(I,1)
  6495.       BUFFER(PTABLE+1) = LXWREC(I,2)
  6496.       IF(ICHK2.EQ.0) BUFFER(PTABLE+3) = ATTCOL
  6497.       BUFFER(PTABLE+4) = IJ
  6498.       NWORDS = ATTWDS
  6499.       BUFFER(PTABLE+5) = ATTLEN
  6500.       IF(NWORDS.EQ.0) NWORDS = 1
  6501.       IJ = IJ + NWORDS
  6502.       BUFFER(PTABLE+6) = ATTYPE
  6503.       IF(ICHK1.NE.0) GO TO 360
  6504.       ICHK1 = LOCATT(ANAME,RNAME1)
  6505.       CALL ATTGET(ISTAT)
  6506.       BUFFER(PTABLE+2) = ATTCOL
  6507.   360 CONTINUE
  6508.       PTABLE = PTABLE + 7
  6509. C
  6510.   400 CONTINUE
  6511.       ICT = IJ - 1
  6512.       GO TO 555
  6513. C
  6514. C  ATTRIBUTE WAS NOT IN EITHER RELATION.
  6515. C
  6516.   450 CONTINUE
  6517.       WRITE(NOUT,9002) ANAME
  6518.  9002 FORMAT(9H -ERROR- ,A8,33H IS NOT COMMON TO EITHER RELATION)
  6519.       GO TO 9999
  6520. C
  6521. C  INTERSECT IS ON ALL ATTRIBUTES
  6522. C
  6523.   500 CONTINUE
  6524.       ICT = 1
  6525. C
  6526. C  STORE DATA FROM RELATION 1 IN PTABLE
  6527. C
  6528.       I = LOCATT(BLANK,RNAME1)
  6529.       DO 515 I=1,NATT1
  6530.       CALL ATTGET(ISTAT)
  6531.       IF(ISTAT.NE.0) GO TO 515
  6532.       NATT3 = NATT3 + 1
  6533.       BUFFER(PTABLE) = IBLANK
  6534.       CALL STRMOV(ATTNAM,1,8,BUFFER(PTABLE),1)
  6535.       BUFFER(PTABLE+2) = ATTCOL
  6536.       BUFFER(PTABLE+4) = ICT
  6537.       NWORDS = ATTWDS
  6538.       BUFFER(PTABLE+5) = ATTLEN
  6539.       IF(NWORDS.EQ.0) NWORDS = 1
  6540.       ICT = ICT + NWORDS
  6541.       BUFFER(PTABLE+6) = ATTYPE
  6542.       PTABLE = PTABLE + 7
  6543.   515 CONTINUE
  6544. C
  6545. C  STORE DATA FROM RELATION 2 IN PTABLE
  6546. C
  6547.       KATT3 = NATT3
  6548.       I = LOCATT(BLANK,RNAME2)
  6549.       DO 550 I=1,NATT2
  6550.       CALL ATTGET(ISTAT)
  6551.       IF(ISTAT.NE.0) GO TO 550
  6552. C
  6553. C  FIRST CHECK TO SEE IF ATTRIBUTE IS ALREADY IN PTABLE.
  6554. C
  6555.       KQ1 = BLKLOC(10) - 7
  6556.       DO 520 J=1,KATT3
  6557.       KQ1 = KQ1 + 7
  6558.       IF(BUFFER(KQ1+3).NE.0) GO TO 520
  6559.       IF(EQ(BUFFER(KQ1),ATTNAM)) GO TO 530
  6560.   520 CONTINUE
  6561. C
  6562. C  NOT THERE -- PUT IT IN.
  6563. C
  6564.       NATT3 = NATT3 + 1
  6565.       BUFFER(PTABLE) = IBLANK
  6566.       CALL STRMOV(ATTNAM,1,8,BUFFER(PTABLE),1)
  6567.       BUFFER(PTABLE+3) = ATTCOL
  6568.       BUFFER(PTABLE+4) = ICT
  6569.       NWORDS = ATTWDS
  6570.       BUFFER(PTABLE+5) = ATTLEN
  6571.       IF(NWORDS.EQ.0) NWORDS = 1
  6572.       ICT = ICT + NWORDS
  6573.       BUFFER(PTABLE+6) = ATTYPE
  6574.       PTABLE = PTABLE + 7
  6575.       GO TO 550
  6576. C
  6577. C  ALREADY THERE -- CHANGE THE 2ND POINTER
  6578. C
  6579.   530 CONTINUE
  6580.       BUFFER(KQ1+3) = ATTCOL
  6581.   550 CONTINUE
  6582.       ICT = ICT - 1
  6583. C
  6584. C  DONE LOADING PTABLE
  6585. C
  6586. C  SEE IF THERE ARE ANY COMMON ATTRIBUTES.
  6587. C
  6588.   555 CONTINUE
  6589.       PTABLE = BLKLOC(10)
  6590.       DO 570 I = 1,NATT3
  6591.       IF((BUFFER(PTABLE+2).NE.0).AND.(BUFFER(PTABLE+3).NE.0)) GO TO 600
  6592.       PTABLE = PTABLE + 7
  6593.   570 CONTINUE
  6594. C
  6595. C  NO COMMON ATTRIBUTES
  6596. C
  6597.       WRITE(NOUT,9003) RNAME1,RNAME2
  6598.  9003 FORMAT(19H -ERROR- RELATIONS ,A8,5H AND ,A8,
  6599.      X26H HAVE NO COMMON ATTRIBUTES)
  6600.       GO TO 9999
  6601. C
  6602. C  PTABLE IS CONSTRUCTED
  6603. C
  6604. C  NOW CREATE ATTRIBUTE AND RELATION TABLES AND THE RELATION
  6605. C
  6606.   600 CONTINUE
  6607.       IF(ICT.GT.MAXCOL) GO TO 9800
  6608. C
  6609. C  SET UP THE WHERE CLAUSE FOR THE INTERSECT.
  6610. C  THIS IS A DUMMY WHERE CLAUSE USED ONLY BY THE KEY PROCESSING
  6611. C
  6612.       KEYCOL = BUFFER(PTABLE+3)
  6613.       KEYTYP = BUFFER(PTABLE+6)
  6614.       NBOO = -1
  6615.       KATTL(1) = BUFFER(PTABLE+5)
  6616.       KATTY(1) = KEYTYP
  6617.       IF(KEYTYP.EQ.KZIVEC) KATTY(1) = KZINT
  6618.       IF(KEYTYP.EQ.KZRVEC) KATTY(1) = KZREAL
  6619.       IF(KEYTYP.EQ.KZDVEC) KATTY(1) = KZDOUB
  6620.       IF(KEYTYP.EQ.KZIMAT) KATTY(1) = KZINT
  6621.       IF(KEYTYP.EQ.KZRMAT) KATTY(1) = KZREAL
  6622.       IF(KEYTYP.EQ.KZDMAT) KATTY(1) = KZDOUB
  6623.       KOMPOS(1) = 1
  6624.       KSTRT = 0
  6625.       MAXTU = ALL9S
  6626.       LIMTU = ALL9S
  6627. C
  6628. C  SET UP RELATION TABLE.
  6629. C
  6630.       NAME = RNAME3
  6631.       CALL RMDATE(RDATE)
  6632.       NCOL = ICT
  6633.       NCOL3 = ICT
  6634.       NATT = NATT3
  6635.       NTUPLE = 0
  6636.       RSTART = 0
  6637.       REND = 0
  6638.       RPW = RPW1
  6639.       MPW = MPW1
  6640.       IF(EQ(RPW,NONE).AND.NE(RPW2,NONE)) RPW = RPW2
  6641.       IF(EQ(MPW,NONE).AND.NE(MPW2,NONE)) MPW = MPW2
  6642.       CALL RELADD
  6643. C
  6644.       CALL ATTNEW(NAME,NATT)
  6645.       PTABLE = BLKLOC(10)
  6646.       DO 700 K=1,NATT3
  6647.       ATTNAM = BLANK
  6648.       CALL STRMOV(BUFFER(PTABLE),1,8,ATTNAM,1)
  6649.       RELNAM = NAME
  6650.       ATTCOL = BUFFER(PTABLE+4)
  6651.       ATTLEN = BUFFER(PTABLE+5)
  6652.       ATTYPE = BUFFER(PTABLE+6)
  6653.       ATTKEY = 0
  6654.       CALL ATTADD
  6655.       PTABLE = PTABLE + 7
  6656.   700 CONTINUE
  6657. C
  6658. C  SEE IF WE CAN DO KEY PROCESSING.
  6659. C
  6660.       PTABLE = BLKLOC(10) - 7
  6661.       DO 800 K=1,NATT3
  6662.       PTABLE = PTABLE + 7
  6663.       IF(BUFFER(PTABLE+2).EQ.0) GO TO 800
  6664.       IF(BUFFER(PTABLE+3).EQ.0) GO TO 800
  6665.       J = LOCATT(BUFFER(PTABLE),RNAME1)
  6666.       IF(J.NE.0) GO TO 800
  6667.       CALL ATTGET(ISTAT)
  6668.       IF(ATTKEY.EQ.0) GO TO 800
  6669. C
  6670. C  WE FOUND A KEY ELEMENT IN MATN1 WHICH IS COMMON.
  6671. C
  6672.       KSTRT = ATTKEY
  6673.       NS = 2
  6674.       KATTL(1) = BUFFER(PTABLE+5)
  6675.       KATTY(1) = BUFFER(PTABLE+6)
  6676.       KEYCOL = BUFFER(PTABLE+3)
  6677.       GO TO 900
  6678.   800 CONTINUE
  6679.   900 CONTINUE
  6680. C
  6681. C  CALL ISECT TO CONSTRUCT MATN3
  6682. C
  6683.       CALL BLKDEF(11,MAXCOL,1)
  6684.       KQ3 = BLKLOC(11)
  6685.       PTABLE = BLKLOC(10)
  6686.       I = LOCREL(RNAME2)
  6687.       CALL ISECT(RNAME1,RNAME3,BUFFER(KQ3),NCOL3,NATT3,BUFFER(PTABLE),
  6688.      XKEYCOL,KEYTYP)
  6689.       GO TO 9999
  6690. C
  6691. C  TUPLE LENGTH EXCEEDS MAXCOL
  6692. C
  6693.  9800 CONTINUE
  6694.       WRITE(NOUT,9810) MAXCOL
  6695.  9810 FORMAT(36H -ERROR- RELATION ROW LENGTH EXCEEDS,I5)
  6696.       GO TO 9999
  6697. C
  6698. C  SYNTAX ERROR IN INTERSECT COMMAND
  6699. C
  6700.  9900 CONTINUE
  6701.       CALL WARN(4,0,0)
  6702. C
  6703. C
  6704. C  DONE WITH INTERSECT
  6705. C
  6706.  9999 CONTINUE
  6707.       CALL BLKCLR(10)
  6708.       CALL BLKCLR(11)
  6709.       RETURN
  6710.       END
  6711.       SUBROUTINE ITOC(STRING,CHAR1,NUMC,INT,IERR)
  6712.         Include TEXT.BLK
  6713. C
  6714. C     THIS ROUTINE CONVERTS AN INTEGER TO TEXT AND PUTS
  6715. C     THE TEXT IN STRING.  IF THE INTEGER WILL NOT FIT, STRING IS
  6716. C     BLANKED OUT AND IERR IS RETURNED NON-ZERO.
  6717. C
  6718. C     STRING....REPOSITORY FOR TEXT OF INT
  6719. C     CHAR1.....1'ST CHARACTER POSITION IN STRING TO USE
  6720. C     NUMC......NUMBER OF CHARACTERS ALLOWED FOR INT
  6721. C               AT MOST 14 CHARACTERS WILL BE USED
  6722. C     INT.......INTEGER TO CONVERT.
  6723. C     IERR......0 IF INT FITS, 1 OTHERWISE
  6724. C
  6725.         Include CONST4.BLK
  6726.         Include MISC.BLK
  6727.       INTEGER STRING(1),CHAR1
  6728.       INTEGER DIGITS(10),C(14)
  6729.       EQUIVALENCE (DIGITS(1),K40)
  6730. C
  6731. C     BLANK OUT STRING
  6732. C
  6733.       IC = CHAR1 - 1
  6734.       DO 10 I=1,NUMC
  6735.       IC = IC + 1
  6736.       CALL PUTT(STRING,IC,BLANK)
  6737.    10 CONTINUE
  6738. C
  6739. C     SEE IF INT FITS
  6740. C
  6741.       NUM = NUMC
  6742.       IF(NUM.GT.9) NUM = 9
  6743.       IN = IABS(INT)
  6744.       IF(INT.LT.0) NUM = NUM - 1
  6745.       IERR = 1
  6746.       IF(IN.GE.10**NUM) GO TO 1000
  6747. C
  6748. C     FITS - BUILD STRING OF CHARACTERS IN C
  6749. C
  6750.       NC = 0
  6751.       IERR = 0
  6752.    20 CONTINUE
  6753.       IN1 = IN/10
  6754.       IC = IN - 10*IN1
  6755.       NC = NC + 1
  6756.       C(NC) = DIGITS(IC+1)
  6757.       IN = IN1
  6758.       IF(IN.GT.0) GO TO 20
  6759. C
  6760. C     NOW BUILD STRING
  6761. C
  6762.       ISTART = CHAR1 + NUMC - NC - 1
  6763.       IF(INT.GE.0) GO TO 40
  6764. C
  6765. C     NEGATIVE - ADD SIGN
  6766. C
  6767.       CALL PUTT(STRING,ISTART,K4MNUS)
  6768.    40 CONTINUE
  6769. C
  6770. C     MOVE IN STRING
  6771. C
  6772.       DO 60 I=1,NC
  6773.       ISTART = ISTART + 1
  6774.       CALL PUTT(STRING,ISTART,C(NC-I+1))
  6775.    60 CONTINUE
  6776.  1000 CONTINUE
  6777.       RETURN
  6778.       END
  6779.       SUBROUTINE ITOH(I,J,K)
  6780.         Include TEXT.BLK
  6781. C
  6782. C  PURPOSE:   UNPACK I AND J FROM K
  6783. C
  6784. C  I WAS MULTIPLIED BY 100000.
  6785. C
  6786.       I = K / 100000
  6787.       J = K - (100000 * I)
  6788.       RETURN
  6789.       END
  6790.       SUBROUTINE JOIN(RNAME1,RNAME3,MATN3,NCOL3,NATT3,PTABLE,
  6791.      XKEYCOL,KEYTYP)
  6792.         Include TEXT.BLK
  6793. C
  6794. C  THIS ROUTINE PERFORMS THE ACTUAL JOIN BETWEEN
  6795. C  RELATION 1 AND 2 FORMING 3
  6796. C
  6797. C  PARAMETERS:
  6798. C         NAME1---NAME OF THE FIRST RELATION
  6799. C         MATN3---DATA TUPLE FOR RELATION 3
  6800. C         NCOL3---NUMBER OF FIXED LENGTH COLUMNS IN MATN3
  6801. C         NATT3---NUMBER OF ATTRIBUTES IN MATN3
  6802. C         PTABLE--POINTER TABLE FOR THIS INTERSECT
  6803. C         KEYCOL--COLUMN OF MATN2 USED FOR SUPPLYING KEY VALUES
  6804. C         KEYTYP--ATTRIBUTE TYPE OF MATN1 USED FOR KEY VALUES
  6805.         Include MISC.BLK
  6806.         Include FILES.BLK
  6807.         Include TUPLER.BLK
  6808.         Include RIMPTR.BLK
  6809.         Include RIMCOM.BLK
  6810.         Include BUFFER.BLK
  6811.         Include WHCOM.BLK
  6812.         Include DCLAR1.BLK
  6813.       DIMENSION MATN3(1)
  6814.       INTEGER PTABLE(7,1)
  6815.       INTEGER ATTLEN
  6816.       INTEGER ENDCOL
  6817. C
  6818. C  INITIALIZE THE MATRIX POINTERS.
  6819. C
  6820.       IERR = 0
  6821.       IDST = 0
  6822.       IDNEW = 0
  6823.       IDCUR = NID
  6824. C
  6825. C  GET THE PARAMETERS FOR THE FIRST MATRIX.
  6826. C
  6827.       I = LOCREL(RNAME1)
  6828.       IDM1 = NID
  6829.       NSP = 0
  6830.       IF(KSTRT.NE.0) NSP = 2
  6831.       NTUP3 = 0
  6832.       ICROW = 0
  6833.       NUMWAR = 0
  6834. C
  6835. C  SEQUENCE THROUGH MATN2.
  6836. C
  6837.   100 CONTINUE
  6838.       IF(IDCUR.EQ.0) GO TO 1000
  6839.       CALL ITOH(N1,N2,IDCUR)
  6840.       IF(N2.EQ.0) GO TO 1000
  6841.       CALL GETDAT(2,IDCUR,MATN2,NCOL2)
  6842.       IF(IDCUR.LT.0) GO TO 1000
  6843.       ICROW = ICROW + 1
  6844. C
  6845. C  MOVE THE COMPARISON VALUE INTO THE WHCOM ARRAYS.
  6846. C
  6847.       CALL ITOH(NCHAR,NWORDS,KATTL(1))
  6848.       IP = MATN2 + KEYCOL - 1
  6849.       IF(NWORDS.NE.0) GO TO 110
  6850. C
  6851. C  SPECIAL GYRATIONS FOR VARIABLE LENGTH STUFF.
  6852. C
  6853.       IP2 = BUFFER(IP)
  6854.       IP = MATN2 + IP2 - 1
  6855.       NWORDS = BUFFER(IP)
  6856.       IF(NWORDS.LE.300) GO TO 105
  6857.       NUMWAR = NUMWAR + 1
  6858.       IF(NUMWAR.LT.100) WRITE (NOUT,103)ICROW
  6859.   103 FORMAT(15H -WARNING- ROW ,I6,
  6860.      X       35H IGNORED BECAUSE ATTRIBUTE TOO LONG)
  6861.       GO TO 100
  6862.   105 CONTINUE
  6863.       IP = IP + 2
  6864.       NCHAR = BUFFER(IP-1)
  6865.   110 CONTINUE
  6866.       CALL HTOI(NCHAR,NWORDS,WHRLEN(1))
  6867.       CALL BLKMOV(WHRVAL(1),BUFFER(IP),NWORDS)
  6868.       NID = IDM1
  6869.       NS = NSP
  6870.   200 CONTINUE
  6871.       CALL RMLOOK(MATN1,1,1,NCOL1)
  6872.       IF(RMSTAT.NE.0) GO TO 100
  6873. C
  6874. C  OKAY -- NOW LOAD THE DATA.
  6875. C
  6876.   400 CONTINUE
  6877.       ENDCOL = NCOL3
  6878.       DO 900 KLM=1,NATT3
  6879.       KOL1 = PTABLE(3,KLM)
  6880.       KOL2 = PTABLE(4,KLM)
  6881.       KOL3 = PTABLE(5,KLM)
  6882.       ATTLEN = PTABLE(6,KLM)
  6883.       CALL ITOH(NCHAR,NWORDS,ATTLEN)
  6884.       IF(NWORDS.EQ.0) GO TO 700
  6885.       DO 600 I=1,NWORDS
  6886.       IF(KOL1.EQ.0) GO TO 500
  6887. C
  6888. C  LOAD THE ATTRIBUTE FROM MATN1.
  6889. C
  6890.       I1 = MATN1 + KOL1 - 1
  6891.       MATN3(KOL3) = BUFFER(I1)
  6892.       KOL3 = KOL3 + 1
  6893.       KOL1 = KOL1 + 1
  6894.       GO TO 600
  6895.   500 CONTINUE
  6896. C
  6897. C  LOAD THE ATTRIBUTE FROM MATN2.
  6898. C
  6899.       I2 = MATN2 + KOL2 - 1
  6900.       MATN3(KOL3) = BUFFER(I2)
  6901.       KOL3 = KOL3 + 1
  6902.       KOL2 = KOL2 + 1
  6903.   600 CONTINUE
  6904.       GO TO 900
  6905.   700 CONTINUE
  6906.       ENDCOL = ENDCOL + 1
  6907.       MATN3(KOL3) = ENDCOL
  6908.       IF(KOL1.EQ.0) GO TO 710
  6909. C
  6910. C  USE POINTERS FROM MATN1.
  6911. C
  6912.       I1 = MATN1 + KOL1 - 1
  6913.       KOL1 = BUFFER(I1)
  6914.       I2 = MATN1 + KOL1 - 1
  6915.       NWORDS = BUFFER(I2)
  6916.       GO TO 720
  6917.   710 CONTINUE
  6918. C
  6919. C  USE POINTERS FROM MATN2.
  6920. C
  6921.       I2 = MATN2 + KOL2 - 1
  6922.       KOL2 = BUFFER(I2)
  6923.       I2 = MATN2 + KOL2 - 1
  6924.       NWORDS = BUFFER(I2)
  6925.   720 CONTINUE
  6926. C
  6927. C  LOAD UP THE VALUES.
  6928. C
  6929.       IF((ENDCOL+NWORDS+1).GT.MAXCOL) GO TO 950
  6930.       MATN3(ENDCOL) = NWORDS
  6931.       NWORDS = NWORDS + 1
  6932.       DO 800 I=1,NWORDS
  6933.       ENDCOL = ENDCOL + 1
  6934.       I2 = I2 + 1
  6935.       MATN3(ENDCOL) = BUFFER(I2)
  6936.   800 CONTINUE
  6937.   900 CONTINUE
  6938.       CALL ADDDAT(3,IDNEW,MATN3,ENDCOL)
  6939.       IF(IDST.EQ.0) IDST = IDNEW
  6940.       NTUP3 = NTUP3 + 1
  6941. C
  6942. C  LOOK FOR MORE IN MATN1.
  6943. C
  6944.       GO TO 200
  6945. C
  6946. C  TUPLE LENGTH EXCEEDS MAXCOL
  6947. C
  6948.   950 CONTINUE
  6949.       IERR = 1
  6950.       WRITE(NOUT,960) MAXCOL
  6951.   960 FORMAT(36H -ERROR- RELATION ROW LENGTH EXCEEDS,I5)
  6952. C
  6953. C  ALL DONE.
  6954. C
  6955.  1000 CONTINUE
  6956.       I = LOCREL(RNAME3)
  6957.       CALL RELGET(ISTAT)
  6958.       RSTART = IDST
  6959.       REND = IDNEW
  6960.       NTUPLE = NTUP3
  6961.       CALL RELPUT
  6962.       NUM = NTUP3
  6963.       IF(IERR.EQ.0) WRITE(NOUT,9000) NUM
  6964.  9000 FORMAT(27H SUCCESSFUL JOIN OPERATION ,
  6965.      XI6,15H ROWS GENERATED)
  6966. C
  6967. C  RETURN
  6968. C
  6969.       RETURN
  6970.       END
  6971.       SUBROUTINE JOIREL
  6972.         Include TEXT.BLK
  6973. C
  6974. C  THIS ROUTINE FINDS THE JOIN OF TWO RELATIONS BASED UPON JOINING
  6975. C  TWO ATTRIBUTES.  THE RESULT FROM THIS PROCESS IS A PHYSICAL
  6976. C  RELATION WHICH HAS TUPLES CONTRUCTED FROM BOTH RELATIONS
  6977. C  WHERE THE SPECIFIED ATTRIBUTES MATCH AS REQUESTED.
  6978. C
  6979. C  THE SYNTAX FOR THE JOIN COMMAND IS:
  6980. C
  6981. C  JOIN REL1 USING ATT1 WITH REL2 USING ATT2 FORMING REL3 WHERE EQ
  6982. C
  6983.         Include RMATTS.BLK
  6984.         Include RMKEYW.BLK
  6985.         Include CONST4.BLK
  6986.         Include FLAGS.BLK
  6987.         Include RIMCOM.BLK
  6988.         Include TUPLER.BLK
  6989.         Include TUPLEA.BLK
  6990.         Include FILES.BLK
  6991.         Include BUFFER.BLK
  6992.         Include WHCOM.BLK
  6993.         Include MISC.BLK
  6994. C
  6995.       INTEGER PTABLE
  6996.       LOGICAL EQ
  6997.       LOGICAL NE
  6998.       LOGICAL EQKEYW
  6999.         Include DCLAR1.BLK
  7000.         Include DCLAR3.BLK
  7001. C
  7002. C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
  7003. C
  7004.       CALL RMDBLK(DBNAME)
  7005.       IF(RMSTAT.EQ.0) GO TO 40
  7006.       CALL WARN(RMSTAT,DBNAME,0)
  7007.       GO TO 9999
  7008. C
  7009. C  LOCAL ARRAYS AND VARIABLES :
  7010. C
  7011. C  PTABLE (MATRIX 10) USED TO CONTROL POINTERS
  7012. C        ROWS1,2 -- ATTRIBUTE NAME
  7013. C        ROW3 -- ATTRIBUTE LOCATION IN RELATION 1
  7014. C        ROW4 -- ATTRIBUTE LOCATION IN RELATION 2
  7015. C        ROW5 -- ATTRIBUTE LOCATION IN RELATION 3
  7016. C        ROW6 -- LENGTH IN WORDS
  7017. C        ROW7 -- ATTRIBUTE TYPE
  7018. C
  7019. C  EDIT COMMAND SYNTAX
  7020. C
  7021.    40 CONTINUE
  7022.       CALL BLKCLN
  7023.       IF(.NOT.EQKEYW(3,KWUSIN,5)) GO TO 9900
  7024.       IF(.NOT.EQKEYW(5,KWWITH,4)) GO TO 9900
  7025.       IF(.NOT.EQKEYW(7,KWUSIN,5)) GO TO 9900
  7026.       IF(.NOT.EQKEYW(9,KWFORM,7)) GO TO 9900
  7027.       ITEMS = LXITEM(IDUMMY)
  7028. C
  7029. C  SET DEFAULT WHERE CONDITION (EQ OR NK = 2)
  7030. C
  7031.       NK = 2
  7032.       IF(ITEMS.LE.10) GO TO 50
  7033. C
  7034. C  CHECK WHERE COMPARISON.
  7035. C
  7036.       IF(.NOT.EQKEYW(11,KWWHER,5)) GO TO 9900
  7037.       NK = LOCBOO(LXWREC(12,1))
  7038.       IF(NK.EQ.0) GO TO 9900
  7039.       IF(NK.EQ.1) GO TO 9900
  7040.    50 CONTINUE
  7041. C
  7042. C  KEYWORD SYNTAX OKAY
  7043. C
  7044.       RNAME1 = BLANK
  7045.       CALL LXSREC(2,1,8,RNAME1,1)
  7046.       I = LOCREL(RNAME1)
  7047.       IF(I.EQ.0) GO TO 100
  7048. C
  7049. C  MISSING FIRST RELATION.
  7050. C
  7051.       CALL WARN(1,RNAME1,0)
  7052.       GO TO 9999
  7053.   100 CONTINUE
  7054. C
  7055. C  SAVE DATA ABOUT RELATION 1
  7056. C
  7057.       I1 = LOCPRM(RNAME1,1)
  7058.       IF(I1.EQ.0) GO TO 110
  7059.       CALL WARN(9,RNAME1,0)
  7060.       GO TO 9999
  7061.   110 CONTINUE
  7062.       NCOL1 = NCOL
  7063.       NATT1 = NATT
  7064.       RPW1 = RPW
  7065.       MPW1 = MPW
  7066. C
  7067. C  CHECK THE COMPARISON ATTRIBUTE.
  7068. C
  7069.       ANAME1 = BLANK
  7070.       CALL LXSREC(4,1,8,ANAME1,1)
  7071.       I = LOCATT(ANAME1,RNAME1)
  7072.       IF(I.NE.0) CALL WARN(3,ANAME1,RNAME1)
  7073.       IF(I.NE.0) GO TO 9999
  7074.       RNAME2 = BLANK
  7075.       CALL LXSREC(6,1,8,RNAME2,1)
  7076.       I = LOCREL(RNAME2)
  7077.       IF(I.EQ.0) GO TO 200
  7078. C
  7079. C  MISSING SECOND RELATION.
  7080. C
  7081.       CALL WARN(1,RNAME2,0)
  7082.       GO TO 9999
  7083.   200 CONTINUE
  7084. C
  7085. C  SAVE DATA ABOUT RELATION 2
  7086. C
  7087.       I2 = LOCPRM(RNAME2,1)
  7088.       IF(I2.EQ.0) GO TO 210
  7089.       CALL WARN(9,RNAME2,0)
  7090.       GO TO 9999
  7091.   210 CONTINUE
  7092.       NCOL2 = NCOL
  7093.       NATT2 = NATT
  7094.       RPW2 = RPW
  7095.       MPW2 = MPW
  7096. C
  7097. C  CHECK THE COMPARISON ATTRIBUTE.
  7098. C
  7099.       ANAME2 = BLANK
  7100.       CALL LXSREC(8,1,8,ANAME2,1)
  7101.       I = LOCATT(ANAME2,RNAME2)
  7102.       IF(I.NE.0) CALL WARN(3,ANAME2,RNAME2)
  7103.       IF(I.NE.0) GO TO 9999
  7104. C
  7105. C  CHECK FOR LEGAL RNAME3
  7106. C
  7107.       IF((LXLENC(10).GE.1).AND.(LXLENC(10).LE.8)) GO TO 250
  7108.       CALL WARN(7,KWRELA,BLANK)
  7109.       GO TO 9999
  7110.   250 CONTINUE
  7111. C
  7112. C  CHECK FOR DUPLICATE RELATION 3
  7113. C
  7114.       RNAME3 = BLANK
  7115.       CALL LXSREC(10,1,8,RNAME3,1)
  7116.       I = LOCREL(RNAME3)
  7117.       IF(I.NE.0) GO TO 300
  7118. C
  7119. C  ERROR
  7120. C
  7121.       WRITE(NOUT,9000)
  7122.  9000 FORMAT(55H -ERROR- RESULTANT RELATION DOES NOT HAVE A UNIQUE NAME)
  7123.       GO TO 9999
  7124. C
  7125. C  CHECK USER READ SECURITY
  7126. C
  7127.   300 CONTINUE
  7128.       IF((I1.NE.0).OR.(I2.NE.0)) GO TO 9999
  7129. C
  7130. C  RELATION NAMES OKAY -- CHECK THE ATTRIBUTES
  7131. C
  7132. C  SET UP PTABLE IN MATRIX POSITION 10
  7133. C
  7134.       CALL BLKDEF(10,7,NATT1+NATT2)
  7135.       PTABLE = BLKLOC(10)
  7136.       NATT3 = 0
  7137.       ICT = 1
  7138. C
  7139. C  STORE DATA FROM RELATION 1 IN PTABLE
  7140. C
  7141.       I = LOCATT(BLANK,RNAME1)
  7142.       DO 500 I=1,NATT1
  7143.       CALL ATTGET(ISTAT)
  7144.       IF(ISTAT.NE.0) GO TO 500
  7145.       NATT3 = NATT3 + 1
  7146.       BUFFER(PTABLE) = IBLANK
  7147.       CALL STRMOV(ATTNAM,1,8,BUFFER(PTABLE),1)
  7148.       BUFFER(PTABLE+2) = ATTCOL
  7149.       BUFFER(PTABLE+4) = ICT
  7150.       NWORDS = ATTWDS
  7151.       BUFFER(PTABLE+5) = ATTLEN
  7152.       IF(NWORDS.EQ.0) NWORDS = 1
  7153.       ICT = ICT + NWORDS
  7154.       BUFFER(PTABLE+6) = ATTYPE
  7155.       PTABLE = PTABLE + 7
  7156.   500 CONTINUE
  7157. C
  7158. C  STORE DATA FROM RELATION 2 IN PTABLE
  7159. C
  7160.       KATT3 = NATT3
  7161.       I = LOCATT(BLANK,RNAME2)
  7162.       DO 550 I=1,NATT2
  7163.       CALL ATTGET(ISTAT)
  7164.       IF(ISTAT.NE.0) GO TO 550
  7165. C
  7166. C  FIRST CHECK TO SEE IF ATTRIBUTE IS ALREADY IN PTABLE.
  7167. C
  7168.       KQ1 = BLKLOC(10) - 7
  7169.       DO 520 J=1,KATT3
  7170.       KQ1 = KQ1 + 7
  7171.       IF(BUFFER(KQ1+3).NE.0) GO TO 520
  7172.       IF(NE(BUFFER(KQ1),ATTNAM)) GO TO 520
  7173.       WRITE(NOUT,9003) ATTNAM
  7174.  9003 FORMAT(11H -WARNING- ,A8,30H IS A DUPLICATE ATTRIBUTE NAME)
  7175.       WRITE(NOUT,9004)
  7176.  9004 FORMAT(53H YOU SHOULD RENAME IT BEFORE DOING QUERIES OR UPDATES)
  7177.       GO TO 530
  7178.   520 CONTINUE
  7179.   530 CONTINUE
  7180. C
  7181. C  ADD THE DATA TO PTABLE.
  7182. C
  7183.       NATT3 = NATT3 + 1
  7184.       BUFFER(PTABLE) = IBLANK
  7185.       CALL STRMOV(ATTNAM,1,8,BUFFER(PTABLE),1)
  7186.       BUFFER(PTABLE+3) = ATTCOL
  7187.       BUFFER(PTABLE+4) = ICT
  7188.       NWORDS = ATTWDS
  7189.       BUFFER(PTABLE+5) = ATTLEN
  7190.       IF(NWORDS.EQ.0) NWORDS = 1
  7191.       ICT = ICT + NWORDS
  7192.       BUFFER(PTABLE+6) = ATTYPE
  7193.       PTABLE = PTABLE + 7
  7194.   550 CONTINUE
  7195.       ICT = ICT - 1
  7196. C
  7197. C  PTABLE IS CONSTRUCTED
  7198. C
  7199. C  NOW CREATE ATTRIBUTE AND RELATION TABLES AND THE RELATION
  7200. C
  7201.       IF(ICT.GT.MAXCOL) GO TO 9850
  7202. C
  7203. C  SET UP THE WHERE CLAUSE FOR THE JOIN.
  7204. C
  7205.       I = LOCATT(ANAME2,RNAME2)
  7206.       CALL ATTGET(ISTAT)
  7207.       IF(ATTWDS.GT.300) GO TO 9870
  7208.       KEYCOL = ATTCOL
  7209.       KEYTYP = ATTYPE
  7210.       KEYLEN = ATTLEN
  7211.       NBOO = 1
  7212.       BOO(1) = K4AND
  7213.       I = LOCATT(ANAME1,RNAME1)
  7214.       CALL ATTGET(ISTAT)
  7215.       KATTP(1) = ATTCOL
  7216.       KATTL(1) = ATTLEN
  7217. C
  7218. C  MAKE SURE THE ATTRIBUTE TYPES MATCH.
  7219. C
  7220.       IF(KEYTYP.NE.ATTYPE) GO TO 9800
  7221.       IF(KEYLEN.NE.ATTLEN) GO TO 9700
  7222.       KATTY(1) = ATTYPE
  7223.       IF(KEYTYP.EQ.KZIVEC) KATTY(1) = KZINT
  7224.       IF(KEYTYP.EQ.KZRVEC) KATTY(1) = KZREAL
  7225.       IF(KEYTYP.EQ.KZDVEC) KATTY(1) = KZDOUB
  7226.       IF(KEYTYP.EQ.KZIMAT) KATTY(1) = KZINT
  7227.       IF(KEYTYP.EQ.KZRMAT) KATTY(1) = KZREAL
  7228.       IF(KEYTYP.EQ.KZDMAT) KATTY(1) = KZDOUB
  7229.       KOMTYP(1) = NK
  7230.       KOMPOS(1) = 1
  7231.       KOMLEN(1) = 1
  7232.       KOMPOT(1) = 1
  7233.       KSTRT = ATTKEY
  7234.       IF(NK.NE.2) KSTRT = 0
  7235.       MAXTU = ALL9S
  7236.       LIMTU = ALL9S
  7237. C
  7238. C  SET UP RELATION TABLE.
  7239. C
  7240.       NAME = RNAME3
  7241.       CALL RMDATE(RDATE)
  7242.       NCOL = ICT
  7243.       NCOL3 = ICT
  7244.       NATT = NATT3
  7245.       NTUPLE = 0
  7246.       RSTART = 0
  7247.       REND = 0
  7248.       RPW = RPW1
  7249.       MPW = MPW1
  7250.       IF(EQ(RPW,NONE).AND.NE(RPW2,NONE)) RPW = RPW2
  7251.       IF(EQ(MPW,NONE).AND.NE(MPW2,NONE)) MPW = MPW2
  7252.       CALL RELADD
  7253. C
  7254.       CALL ATTNEW(NAME,NATT)
  7255.       PTABLE = BLKLOC(10)
  7256.       DO 700 K=1,NATT3
  7257.       ATTNAM = BLANK
  7258.       CALL STRMOV(BUFFER(PTABLE),1,8,ATTNAM,1)
  7259.       RELNAM = NAME
  7260.       ATTCOL = BUFFER(PTABLE+4)
  7261.       ATTLEN = BUFFER(PTABLE+5)
  7262.       ATTYPE = BUFFER(PTABLE+6)
  7263.       ATTKEY = 0
  7264.       CALL ATTADD
  7265.       PTABLE = PTABLE + 7
  7266.   700 CONTINUE
  7267. C
  7268. C  CALL JOIN TO CONSTRUCT MATN3
  7269. C
  7270.       CALL BLKDEF(11,MAXCOL,1)
  7271.       KQ3 = BLKLOC(11)
  7272.       PTABLE = BLKLOC(10)
  7273.       I = LOCREL(RNAME2)
  7274.       CALL JOIN(RNAME1,RNAME3,BUFFER(KQ3),NCOL3,NATT3,BUFFER(PTABLE),
  7275.      XKEYCOL,KEYTYP)
  7276.       GO TO 9999
  7277. C
  7278. C  MISMATCHED DATA TYPES.
  7279. C
  7280.  9700 CONTINUE
  7281.       WRITE(NOUT,9006)
  7282.  9006 FORMAT(46H -ERROR- JOIN ATTRIBUTES ARE DIFFERENT LENGTHS )
  7283.       GO TO 9999
  7284.  9800 CONTINUE
  7285.       WRITE(NOUT,9005)
  7286.  9005 FORMAT(44H -ERROR- JOIN ATTRIBUTES ARE DIFFERENT TYPES)
  7287.       GO TO 9999
  7288. C
  7289. C  TUPLE LENGTH EXCEEDS MAXCOL
  7290. C
  7291.  9850 CONTINUE
  7292.       WRITE(NOUT,9860) MAXCOL
  7293.  9860 FORMAT(36H -ERROR- RELATION ROW LENGTH EXCEEDS,I5)
  7294.       GO TO 9999
  7295.  9870 CONTINUE
  7296.       WRITE (NOUT,9880)
  7297.  9880 FORMAT(32H -ERROR- JOIN ATTRIBUTE TOO LONG )
  7298.       GO TO 9999
  7299. C
  7300. C  SYNTAX ERROR IN JOIN COMMAND
  7301. C
  7302.  9900 CONTINUE
  7303.       CALL WARN(4,0,0)
  7304. C
  7305. C
  7306. C  DONE WITH INTERSECT
  7307. C
  7308.  9999 CONTINUE
  7309.       CALL BLKCLR(10)
  7310.       CALL BLKCLR(11)
  7311.       RETURN
  7312.       END
  7313.       SUBROUTINE KMPARD(VALUE1,VALUE2,LEN,NK,OK)
  7314.         Include TEXT.BLK
  7315. C
  7316. C  THIS ROUTINE COMPARES VALUE1 AND VALUE2 TO SEE IF THEY MEET THE
  7317. C  DESIRED CONDITIONS.
  7318. C
  7319. C  PARAMETERS
  7320. C         VALUE1--FIRST VALUE
  7321. C         VALUE2--SECOND VALUE
  7322. C         LEN-----VALUE LENGTHS
  7323. C         NK------NUMBER FOR COMPARISON TYPE
  7324.  
  7325. C         OK------.FALSE. COMING IN, .TRUE. GOING OUT IF THE CONDITIONS
  7326. C                 ARE MET
  7327. C
  7328.         Include FLAGS.BLK
  7329.       DOUBLE PRECISION TOLL
  7330.       DOUBLE PRECISION VALUE1(1),VALUE2(1)
  7331.       LOGICAL OK
  7332.       TOLL = TOL
  7333. C
  7334. C  BRANCH ON THE VALUE OF NK.
  7335. C
  7336.       IF(NK.NE.2) GO TO 30
  7337. C  EQ.
  7338.       IF(TOL.NE.0.) GO TO 26
  7339.       DO 25 I=1,LEN
  7340.       IF(VALUE1(I).NE.VALUE2(I)) GO TO 999
  7341.    25 CONTINUE
  7342.       GO TO 900
  7343.    26 CONTINUE
  7344.       IF(PCENT) GO TO 28
  7345.       DO 27 I=1,LEN
  7346.       IF(VALUE1(I).LT.(VALUE2(I)-TOLL)) GO TO 999
  7347.       IF(VALUE1(I).GT.(VALUE2(I)+TOLL)) GO TO 999
  7348.    27 CONTINUE
  7349.       GO TO 900
  7350.    28 CONTINUE
  7351.       DO 29 I=1,LEN
  7352.       IF(VALUE1(I).LT.(VALUE2(I)*(1.-TOLL))) GO TO 999
  7353.       IF(VALUE1(I).GT.(VALUE2(I)*(1.+TOLL))) GO TO 999
  7354.    29 CONTINUE
  7355.       GO TO 900
  7356.    30 IF(NK.NE.3) GO TO 40
  7357. C  NE.
  7358.       IF(TOL.NE.0.) GO TO 36
  7359.       DO 35 I=1,LEN
  7360.       IF(VALUE1(I).NE.VALUE2(I)) GO TO 900
  7361.    35 CONTINUE
  7362.       GO TO 999
  7363.    36 CONTINUE
  7364.       IF(PCENT) GO TO 38
  7365.       DO 37 I=1,LEN
  7366.       IF(VALUE1(I).LT.(VALUE2(I)-TOLL)) GO TO 900
  7367.       IF(VALUE1(I).GT.(VALUE2(I)+TOLL)) GO TO 900
  7368.    37 CONTINUE
  7369.       GO TO 999
  7370.    38 CONTINUE
  7371.       DO 39 I=1,LEN
  7372.       IF(VALUE1(I).LT.(VALUE2(I)*(1.-TOLL))) GO TO 900
  7373.       IF(VALUE1(I).GT.(VALUE2(I)*(1.+TOLL))) GO TO 900
  7374.    39 CONTINUE
  7375.       GO TO 999
  7376.    40 IF((NK.NE.4).AND.(NK.NE.5)) GO TO 60
  7377. C  GT AND GE.
  7378.       DO 45 I=1,LEN
  7379.       IF(VALUE1(I).GT.VALUE2(I)) GO TO 900
  7380.       IF(VALUE1(I).LT.VALUE2(I)) GO TO 999
  7381.    45 CONTINUE
  7382.       IF(NK.EQ.5) GO TO 900
  7383.       GO TO 999
  7384.    60 IF((NK.NE.6).AND.(NK.NE.7)) GO TO 80
  7385. C  LT AND LE.
  7386.       DO 65 I=1,LEN
  7387.       IF(VALUE1(I).LT.VALUE2(I)) GO TO 900
  7388.       IF(VALUE1(I).GT.VALUE2(I)) GO TO 999
  7389.    65 CONTINUE
  7390.       IF(NK.EQ.7) GO TO 900
  7391.       GO TO 999
  7392.    80 CONTINUE
  7393.       GO TO 999
  7394.   900 OK = .TRUE.
  7395.   999 RETURN
  7396.       END
  7397.       SUBROUTINE KMPARI(VALUE1,VALUE2,LEN,NK,OK)
  7398.         Include TEXT.BLK
  7399. C
  7400. C  THIS ROUTINE COMPARES VALUE1 AND VALUE2 TO SEE IF THEY MEET THE
  7401. C  DESIRED CONDITIONS.
  7402. C
  7403. C  PARAMETERS
  7404. C         VALUE1--FIRST VALUE
  7405. C         VALUE2--SECOND VALUE
  7406. C         LEN-----VALUE LENGTHS
  7407. C         NK------NUMBER FOR COMPARISON TYPE
  7408. C         OK------.FALSE. COMING IN, .TRUE. GOING OUT IF THE CONDITIONS
  7409. C                 ARE MET
  7410. C
  7411.       INTEGER VALUE1(1),VALUE2(1)
  7412.       LOGICAL OK
  7413. C
  7414. C  BRANCH ON THE VALUE OF NK.
  7415. C
  7416.       IF(NK.NE.2) GO TO 30
  7417. C  EQ.
  7418.       DO 25 I=1,LEN
  7419.       IF(VALUE1(I).NE.VALUE2(I)) GO TO 999
  7420.    25 CONTINUE
  7421.       GO TO 900
  7422.    30 IF(NK.NE.3) GO TO 40
  7423. C  NE.
  7424.       DO 35 I=1,LEN
  7425.       IF(VALUE1(I).NE.VALUE2(I)) GO TO 900
  7426.    35 CONTINUE
  7427.       GO TO 999
  7428.    40 IF((NK.NE.4).AND.(NK.NE.5)) GO TO 60
  7429. C  GT AND GE.
  7430.       DO 45 I=1,LEN
  7431.       IF(VALUE1(I).GT.VALUE2(I)) GO TO 900
  7432.       IF(VALUE1(I).LT.VALUE2(I)) GO TO 999
  7433.    45 CONTINUE
  7434.       IF(NK.EQ.5) GO TO 900
  7435.       GO TO 999
  7436.    60 IF((NK.NE.6).AND.(NK.NE.7)) GO TO 80
  7437. C  LT AND LE.
  7438.       DO 65 I=1,LEN
  7439.       IF(VALUE1(I).LT.VALUE2(I)) GO TO 900
  7440.       IF(VALUE1(I).GT.VALUE2(I)) GO TO 999
  7441.    65 CONTINUE
  7442.       IF(NK.EQ.7) GO TO 900
  7443.       GO TO 999
  7444.    80 CONTINUE
  7445.       GO TO 999
  7446.   900 OK = .TRUE.
  7447.   999 RETURN
  7448.       END
  7449.       SUBROUTINE KMPARR(VALUE1,VALUE2,LEN,NK,OK)
  7450.         Include TEXT.BLK
  7451. C
  7452. C  THIS ROUTINE COMPARES VALUE1 AND VALUE2 TO SEE IF THEY MEET THE
  7453. C  DESIRED CONDITIONS.
  7454. C
  7455. C  PARAMETERS
  7456. C         VALUE1--FIRST VALUE
  7457. C         VALUE2--SECOND VALUE
  7458. C         LEN-----VALUE LENGTHS
  7459. C         NK------NUMBER FOR COMPARISON TYPE
  7460. C         OK------.FALSE. COMING IN, .TRUE. GOING OUT IF THE CONDITIONS
  7461. C                 ARE MET
  7462. C
  7463.         Include FLAGS.BLK
  7464.       REAL VALUE1(1),VALUE2(1)
  7465.       LOGICAL OK
  7466. C
  7467. C  BRANCH ON THE VALUE OF NK.
  7468. C
  7469.       IF(NK.NE.2) GO TO 30
  7470. C  EQ.
  7471.       IF(TOL.NE.0.) GO TO 26
  7472.       DO 25 I=1,LEN
  7473.       IF(VALUE1(I).NE.VALUE2(I)) GO TO 999
  7474.    25 CONTINUE
  7475.       GO TO 900
  7476.    26 CONTINUE
  7477.       IF(PCENT) GO TO 28
  7478.       DO 27 I=1,LEN
  7479.       IF(VALUE1(I).LT.(VALUE2(I)-TOL)) GO TO 999
  7480.       IF(VALUE1(I).GT.(VALUE2(I)+TOL)) GO TO 999
  7481.    27 CONTINUE
  7482.       GO TO 900
  7483.    28 CONTINUE
  7484.       DO 29 I=1,LEN
  7485.       IF(VALUE1(I).LT.(VALUE2(I)*(1.-TOL))) GO TO 999
  7486.       IF(VALUE1(I).GT.(VALUE2(I)*(1.+TOL))) GO TO 999
  7487.    29 CONTINUE
  7488.       GO TO 900
  7489.    30 IF(NK.NE.3) GO TO 40
  7490. C  NE.
  7491.       IF(TOL.NE.0.) GO TO 36
  7492.       DO 35 I=1,LEN
  7493.       IF(VALUE1(I).NE.VALUE2(I)) GO TO 900
  7494.    35 CONTINUE
  7495.       GO TO 999
  7496.    36 CONTINUE
  7497.       IF(PCENT) GO TO 38
  7498.       DO 37 I=1,LEN
  7499.       IF(VALUE1(I).LT.(VALUE2(I)-TOL)) GO TO 900
  7500.       IF(VALUE1(I).GT.(VALUE2(I)+TOL)) GO TO 900
  7501.    37 CONTINUE
  7502.       GO TO 999
  7503.    38 CONTINUE
  7504.       DO 39 I=1,LEN
  7505.       IF(VALUE1(I).LT.(VALUE2(I)*(1.-TOL))) GO TO 900
  7506.       IF(VALUE1(I).GT.(VALUE2(I)*(1.+TOL))) GO TO 900
  7507.    39 CONTINUE
  7508.       GO TO 999
  7509.    40 IF((NK.NE.4).AND.(NK.NE.5)) GO TO 60
  7510. C  GT AND GE.
  7511.       DO 45 I=1,LEN
  7512.       IF(VALUE1(I).GT.VALUE2(I)) GO TO 900
  7513.       IF(VALUE1(I).LT.VALUE2(I)) GO TO 999
  7514.    45 CONTINUE
  7515.       IF(NK.EQ.5) GO TO 900
  7516.       GO TO 999
  7517.    60 IF((NK.NE.6).AND.(NK.NE.7)) GO TO 80
  7518. C  LT AND LE.
  7519.       DO 65 I=1,LEN
  7520.       IF(VALUE1(I).LT.VALUE2(I)) GO TO 900
  7521.       IF(VALUE1(I).GT.VALUE2(I)) GO TO 999
  7522.    65 CONTINUE
  7523.       IF(NK.EQ.7) GO TO 900
  7524.       GO TO 999
  7525.    80 CONTINUE
  7526.       GO TO 999
  7527.   900 OK = .TRUE.
  7528.   999 RETURN
  7529.       END
  7530.       SUBROUTINE KMPART(VALUE1,VALUE2,LEN,NK,OK)
  7531.         Include TEXT.BLK
  7532. C
  7533. C     THIS ROUTINE COMPARES LEN'S WORTH OF TEXT WORDS TO
  7534. C     SEE IF THEY MEET THE SPECIFIED CONDITION.
  7535. C     THE ROUTINE SWITCP IS USED TO ACTUALLY COMPARE
  7536. C     TWO WORDS.
  7537. C
  7538. C     PARAMETERS
  7539. C       VALUE1....LIST OF WORDS OF TEXT
  7540. C       VALUE2....LIST OF WORDS OF TEXT
  7541. C       LEN.......LENGTH OF VALUE1,VALUE2
  7542. C       NK........VALUE1 NK'S VALUE2
  7543. C                 NK IS AN INTEGER WITH THE FOLLOWING VALUES
  7544. C                 NK=2   EQ
  7545. C                    3   NE
  7546. C                    4   GT
  7547. C                    5   GE
  7548. C                    6   LT
  7549. C                    7   LE
  7550. C
  7551. C       OK........ .FALSE. COMING IN, .TRUE. GOING OUT IF
  7552. C                 CONDITION IS SATISFIED.
  7553. C
  7554.       INTEGER VALUE1(LEN),VALUE2(LEN)
  7555.       INTEGER SWITCP
  7556.       LOGICAL OK
  7557.       IF(NK.LT.2) GO TO 999
  7558.       IF(NK.GT.7) GO TO 999
  7559. C
  7560. C     LOOP ON VALUES TO COMPARE
  7561. C
  7562.       DO 100 I=1,LEN
  7563. C
  7564. C  COMPARE TWO VALUES 0=EQ  -1=GT  1=LT
  7565. C
  7566.       J = SWITCP(VALUE1(I),VALUE2(I))
  7567.       IF(J.EQ.0) GO TO 100
  7568.       IF(NK.EQ.2) GO TO 999
  7569.       K = 5 - J
  7570.       IF(NK.EQ.K) GO TO 999
  7571.       IF(NK.EQ.K+1) GO TO 999
  7572.       GO TO 200
  7573.   100 CONTINUE
  7574. C
  7575. C     EQUAL
  7576. C
  7577.       IF(NK.EQ.3) GO TO 999
  7578.       IF(NK.EQ.4) GO TO 999
  7579.       IF(NK.EQ.6) GO TO 999
  7580.   200 CONTINUE
  7581.       OK = .TRUE.
  7582.   999 CONTINUE
  7583.       RETURN
  7584.       END
  7585.       SUBROUTINE KOMPXX(VALUE1,VALUE2,LEN,NK,OK,TYPE)
  7586.         Include TEXT.BLK
  7587. C
  7588. C  THIS ROUTINE COMPARES VALUE1 AND VALUE2 TO SEE IF THEY MEET THE
  7589. C  DESIRED CONDITIONS.
  7590. C
  7591. C  PARAMETERS
  7592. C         VALUE1--FIRST VALUE
  7593. C         VALUE2--SECOND VALUE
  7594. C         LEN-----VALUE LENGTHS
  7595. C         NK------NUMBER FOR COMPARISON TYPE
  7596. C         OK------.FALSE. COMING IN, .TRUE. GOING OUT IF THE CONDITIONS
  7597. C                 ARE MET
  7598. C         TYPE----TYPE OF VALUES BEING COMPARED
  7599. C
  7600.         Include RMATTS.BLK
  7601.         Include MISC.BLK
  7602. C
  7603.       INTEGER VALUE1(1)
  7604.       INTEGER VALUE2(1)
  7605.       INTEGER TYPE
  7606.       LOGICAL OK
  7607.       IF(NK.NE.-1) GO TO 10
  7608. C  FAILS.
  7609.       IF(VALUE1(1).EQ.NULL) OK = .TRUE.
  7610.       GO TO 999
  7611.    10 CONTINUE
  7612.       IF(VALUE1(1).EQ.NULL) GO TO 999
  7613.       IF(NK.NE.1) GO TO 20
  7614. C  EXISTS
  7615.       OK = .TRUE.
  7616.       GO TO 999
  7617.    20 CONTINUE
  7618.       IF(TYPE.EQ.KZINT)
  7619.      X CALL KMPARI(VALUE1,VALUE2,LEN,NK,OK)
  7620.       IF(TYPE.EQ.KZREAL)
  7621.      X CALL KMPARR(VALUE1,VALUE2,LEN,NK,OK)
  7622.       IF(TYPE.EQ.KZDOUB)
  7623.      X CALL KMPARD(VALUE1,VALUE2,LEN/2,NK,OK)
  7624.       IF(TYPE.EQ.KZTEXT)
  7625.      X CALL KMPART(VALUE1,VALUE2,LEN,NK,OK)
  7626.   999 CONTINUE
  7627.       RETURN
  7628.       END
  7629.       INTEGER FUNCTION LFIND(ITEM1,NUM,KEY,NCHAR)
  7630.         Include TEXT.BLK
  7631. C
  7632. C     THIS ROUTINE LOOKS FOR A KEYWORD IN THE LXLREC
  7633. C     RECORD.  IT RETURNS 0 IF NOT FOUND AND THE ITEM
  7634. C     NUMBER IF FOUND.
  7635. C
  7636.       LOGICAL EQKEYW
  7637.       INTEGER KEY(1)
  7638.       NEND = ITEM1 + NUM - 1
  7639.       DO 10 J=ITEM1,NEND
  7640.       IF(EQKEYW(J,KEY,NCHAR)) GO TO 20
  7641.    10 CONTINUE
  7642.       J = 0
  7643.    20 CONTINUE
  7644.       LFIND = J
  7645.       RETURN
  7646.       END
  7647.       SUBROUTINE LOADIT(MAT)
  7648.         Include TEXT.BLK
  7649. C
  7650. C  THIS ROUTINE IS THE FORTRAN ROUTINE FOR LOADING DATA VALUES IN THE
  7651. C  RIM DATA BASE.
  7652. C
  7653. C  PARAMETERS:
  7654. C         MAT-----SCRATCH ARRAY FOR BUILDING TUPLES
  7655. C
  7656.         Include CONST4.BLK
  7657.         Include RMKEYW.BLK
  7658.         Include FILES.BLK
  7659.         Include RULCOM.BLK
  7660.         Include START.BLK
  7661.         Include TUPLEA.BLK
  7662.         Include TUPLER.BLK
  7663.         Include MISC.BLK
  7664.         Include FLAGS.BLK
  7665. C
  7666. C  DIMENSION STATEMENTS.
  7667.       INTEGER COLUMN
  7668.       LOGICAL EQKEYW
  7669.       DOUBLE PRECISION DTEMP
  7670.       REAL TEMP(2)
  7671.       INTEGER ITEMP(2)
  7672.       EQUIVALENCE (DTEMP,TEMP(1))
  7673.       EQUIVALENCE (TEMP(1),ITEMP(1))
  7674.       INTEGER ENDCOL
  7675.       INTEGER MAT(1)
  7676. C
  7677. C  READ A CARD.
  7678. C
  7679.   100 CONTINUE
  7680.       CALL LODREC
  7681.       LSTCMD = K4LOA
  7682.       ITEMS = LXITEM(IDUMMY)
  7683.       IF(ITEMS.GT.2) GO TO 160
  7684.       IF(EQKEYW(1,KWLOAD,4)) GO TO 5000
  7685.       IF(ITEMS.GT.1) GO TO 160
  7686.       IF(EQKEYW(1,KWCHEC,5)) GO TO 3000
  7687.       IF(EQKEYW(1,KWNOCH,7)) GO TO 4000
  7688.       IF(EQKEYW(1,KWEND,3)) GO TO 5000
  7689.   160 CONTINUE
  7690. C
  7691. C  ASSUME THIS IS A DATA CARD.
  7692. C
  7693. C  ZERO OUT THE TUPLE.
  7694. C
  7695.       CALL ZEROIT(MAT,MAXCOL)
  7696. C
  7697. C  CHECK EACH ATTRIBUTE AND MOVE IT TO THE TUPLE FROM INPUT.
  7698. C
  7699.       NUMKEY = 0
  7700.       I = LOCATT(BLANK,NAME)
  7701.       IF(I.NE.0) GO TO 5000
  7702.       J = 1
  7703.       ENDCOL = NCOL + 1
  7704.       DO 1000 I=1,NATT
  7705.       CALL ATTGET(ISTAT)
  7706.       IF(ISTAT.NE.0) GO TO 2300
  7707.       COLUMN = ATTCOL
  7708.       IF(ATTKEY.NE.0) NUMKEY = NUMKEY + 1
  7709. C
  7710. C     CALL PARVAL TO CRACH VALUE STRING
  7711. C
  7712.       IF(ATTWDS.EQ.0) GO TO 200
  7713. C
  7714. C     FIXED ATTRIBUTE
  7715. C
  7716.       CALL PARVAL(J,MAT(COLUMN),ATTYPE,ATTWDS,ATTCHA,0,IERR)
  7717.       IF(IERR.NE.0) GO TO 100
  7718.       GO TO 1000
  7719.   200 CONTINUE
  7720. C
  7721. C     VARIABLE ATTRIBUTE
  7722. C
  7723.       MAT(COLUMN) = ENDCOL
  7724.       NCOLT = ENDCOL + 1
  7725.       CALL PARVAL(J,MAT(ENDCOL+2),ATTYPE,ATTWDS,ATTCHA,NCOLT,IERR)
  7726.       IF(IERR.NE.0) GO TO 100
  7727.       MAT(ENDCOL) = ATTWDS
  7728.       MAT(ENDCOL+1) = ATTCHA
  7729.       ENDCOL = ENDCOL + ATTWDS + 2
  7730.  1000 CONTINUE
  7731.       ENDCOL = ENDCOL - 1
  7732.       IF(J.LE.ITEMS) GO TO 2400
  7733. C
  7734. C  SEE IF ALL APPLICABLE RULES ARE SATISFIED.
  7735. C
  7736.       IF(.NOT.RUCK) GO TO 1100
  7737.       IF(.NOT.RULES) GO TO 1100
  7738.       CALL CHKTUP(MAT,ISTAT)
  7739.       IF(ISTAT.EQ.0) GO TO 1100
  7740.       IF(ISTAT.LT.0) GO TO 1050
  7741.       WRITE(NOUT,1010)
  7742.  1010 FORMAT(53H -ERROR- THE DATA FAILS TO SATISFY THE FOLLOWING RULE,/)
  7743.       ISNOUT = NOUTR
  7744.       NOUTR = NOUT
  7745.       CALL PRULE(ISTAT)
  7746.       NOUTR = ISNOUT
  7747.       GO TO 100
  7748.  1050 CONTINUE
  7749.       ISTAT = -ISTAT
  7750.       WRITE(NOUT,1060) ISTAT
  7751.  1060 FORMAT(32H -ERROR- UNABLE TO PROCESS RULE ,I4)
  7752.       GO TO 100
  7753.  1100 CONTINUE
  7754.       NTUPLE = NTUPLE + 1
  7755.       CALL ADDDAT(1,REND,MAT,ENDCOL)
  7756.       IF(RSTART.EQ.0) RSTART = REND
  7757.       CALL RELPUT
  7758. C
  7759. C  PROCESS ANY KEY ATTRIBUTES.
  7760. C
  7761.       IF(NUMKEY.EQ.0) GO TO 100
  7762.       I = LOCATT(BLANK,NAME)
  7763.       DO 1500 I=1,NATT
  7764.       CALL ATTGET(ISTAT)
  7765.       IF(ISTAT.NE.0) GO TO 2300
  7766.       IF(ATTKEY.EQ.0) GO TO 1500
  7767.       START = ATTKEY
  7768.       KSTART = ATTKEY
  7769.       COLUMN = ATTCOL
  7770.       IF(ATTWDS.NE.0) GO TO 1400
  7771.       COLUMN = MAT(ATTCOL) + 2
  7772.  1400 CONTINUE
  7773.       IF(MAT(COLUMN).EQ.NULL) GO TO 1500
  7774.       CALL BTADD(MAT(COLUMN),REND,ATTYPE)
  7775.       IF(START.EQ.KSTART) GO TO 1500
  7776.       ATTKEY = START
  7777.       CALL ATTPUT(ISTAT)
  7778.  1500 CONTINUE
  7779.       GO TO 100
  7780. C
  7781. C  ATTGET RAN OUT OF ATTRIBUTES TOO SOON.
  7782. C
  7783.  2300 CONTINUE
  7784.       WRITE(NOUT,9004)
  7785.  9004 FORMAT(34H -ERROR- ATTRIBUTE TABLE TOO SHORT)
  7786.       GO TO 100
  7787.  2400 CONTINUE
  7788. C
  7789. C     TOO MANY ITEMS
  7790. C
  7791.       WRITE (NOUT,2450)
  7792.  2450 FORMAT(33H -ERROR- TOO MANY ITEMS ON RECORD )
  7793.       GO TO 100
  7794. C
  7795. C  CHECK ON.
  7796. C
  7797.  3000 CONTINUE
  7798.       RUCK = .TRUE.
  7799.       GO TO 100
  7800. C
  7801. C  CHECK OFF.
  7802. C
  7803.  4000 CONTINUE
  7804.       RUCK = .FALSE.
  7805.       GO TO 100
  7806. C
  7807. C  ALL DONE.
  7808. C
  7809.  5000 CONTINUE
  7810.       RETURN
  7811.       END
  7812.       FUNCTION LOCATT(ANAME,RNAME)
  7813.         Include TEXT.BLK
  7814. C
  7815. C  PURPOSE:   LOOK FOR ATTRIBUTES AND RELATIONS IN THE ATTRIBUTE
  7816. C             RELATION
  7817. C
  7818. C  PARAMETERS:
  7819. C         ANAME---NAME OF ATTRIBUTE OR BLANKS
  7820. C         RNAME---NAME OF RELATION OR BLANKS
  7821. C         LOCATT--STATUS VARIABLE - 0 MEANS OK, 1 MEANS NO WAY
  7822.         Include ATTBLE.BLK
  7823.         Include START.BLK
  7824.         Include MISC.BLK
  7825.       LOGICAL EQ
  7826.       LOGICAL NE
  7827.         Include DCLAR1.BLK
  7828.         Include DATA1.BLK
  7829.       LOCATT = 0
  7830. C
  7831. C  SEE WHAT THE CALLER WANTS.
  7832. C
  7833.       IF(EQ(RNAME,BLANK)) GO TO 1000
  7834. C
  7835. C  RNAME IS SPECIFIED.
  7836. C
  7837. C
  7838. C  FIND THE START FOR THIS RELATION.
  7839. C
  7840. C
  7841. C  GET THE PAGE WITH THE DATA FOR THIS RELATION.
  7842. C
  7843.   100 CONTINUE
  7844.       CRNAME = RNAME
  7845.       MRSTRT = MSTRTP
  7846.   200 CONTINUE
  7847.       CALL ATTPAG(MRSTRT)
  7848. C
  7849. C  LOOK FOR THE ATTRIBUTE IN THIS RELATION.
  7850. C
  7851.       I = MRSTRT
  7852.   300 CONTINUE
  7853.       IF(I.GT.APBUF) GO TO 400
  7854.       IF(ATTBLE(1,I).LT.0) GO TO 350
  7855.       IF(NE(ATTBLE(4,I),RNAME)) GO TO 350
  7856.       IF(ANAME.EQ.BLANK) GO TO 500
  7857.       IF(EQ(ATTBLE(2,I),ANAME)) GO TO 500
  7858.   350 CONTINUE
  7859.       I = I + 1
  7860.       GO TO 300
  7861. C
  7862. C  GET THE NEXT PAGE.
  7863. C
  7864.   400 CONTINUE
  7865.       MRSTRT = ATTBUF(1)
  7866.       IF(MRSTRT.EQ.0) GO TO 9000
  7867.       GO TO 200
  7868. C
  7869. C  WE FOUND THE ROW WE ARE LOOKING FOR.
  7870. C
  7871.   500 CONTINUE
  7872.       CANAME = ANAME
  7873.       CROW = I
  7874.       LROW = 0
  7875.       GO TO 9999
  7876. C
  7877. C  SCAN FOR ATTRIBUTE WITHOUT RELATION SPECIFIED.
  7878. C
  7879.  1000 CONTINUE
  7880.       IF(EQ(ANAME,BLANK)) GO TO 9000
  7881.       MRSTRT = MSTRTP
  7882.  1100 CONTINUE
  7883.       CALL ATTPAG(MRSTRT)
  7884.       I = MRSTRT
  7885.  1200 CONTINUE
  7886.       IF(I.GT.APBUF) GO TO 1400
  7887.       IF(ATTBLE(1,I).LT.0) GO TO 1300
  7888.       IF(EQ(ATTBLE(2,I),ANAME)) GO TO 1500
  7889.  1300 CONTINUE
  7890.       I = I + 1
  7891.       GO TO 1200
  7892. C
  7893. C  GET THE NEXT PAGE.
  7894. C
  7895.  1400 CONTINUE
  7896.       MRSTRT = ATTBUF(1)
  7897.       IF(MRSTRT.EQ.0) GO TO 9000
  7898.       GO TO 1100
  7899. C
  7900. C  FOUND IT.
  7901. C
  7902.  1500 CONTINUE
  7903.       CRNAME = BLANK
  7904.       CANAME = ANAME
  7905.       CROW = I
  7906.       LROW = 0
  7907.       GO TO 9999
  7908. C
  7909. C  UNABLE TO FIND WHAT WE ARE LOOKING FOR.
  7910. C
  7911.  9000 CONTINUE
  7912.       CRNAME = 0
  7913.       CANAME = 0
  7914.       LOCATT = 1
  7915.       CROW = 0
  7916.       LROW = 0
  7917.  9999 CONTINUE
  7918.       RETURN
  7919.       END
  7920.       FUNCTION LOCBOO(KOMPAR)
  7921.         Include TEXT.BLK
  7922. C
  7923. C  FIND THE TYPE OF BOOLEAN COMPARISON THAT KOMPAR IS.
  7924. C  JUST CHECK THE FIRST 3 CHARACTERS
  7925. C
  7926. C  PARAMETERS:
  7927. C         KOMPAR--BOOLEAN OPERATOR
  7928. C         LOCBOO--CORRESPONDING NUMBER
  7929. C
  7930.         Include CONST4.BLK
  7931.         Include MISC.BLK
  7932.       INTEGER BOOL(17)
  7933.       EQUIVALENCE (BOOL(1),K4BOOL(1))
  7934.       CALL FILCH(KOM,1,CHPWD,BLANK)
  7935.       CALL STRMOV(KOMPAR,1,3,KOM,1)
  7936.       DO 100 I=1,17
  7937.       IF(KOM.EQ.BOOL(I)) GO TO 200
  7938.   100 CONTINUE
  7939.       I = 0
  7940.       IF(KOM.EQ.K4CON) I = 9
  7941.   200 LOCBOO = I
  7942.       IF(I.EQ.8) LOCBOO = -1
  7943.       RETURN
  7944.       END
  7945.       FUNCTION LOCPRM(RNAME,JCODE)
  7946.         Include TEXT.BLK
  7947. C
  7948. C  CHECK PERMISSION FOR A USERID AGAINST A RELATION.
  7949. C
  7950. C  PARAMETERS:
  7951. C         RNAME---RELATION NAME
  7952. C         JCODE---READ/MODIFY CODE
  7953. C                 1 FOR READ
  7954. C                 2 FOR MODIFY
  7955. C         LOCPRM--O FOR OK, 1 FOR NO-WAY
  7956.         Include FLAGS.BLK
  7957.         Include RIMCOM.BLK
  7958.         Include TUPLER.BLK
  7959.         Include MISC.BLK
  7960.       LOGICAL EQ
  7961.         Include DCLAR1.BLK
  7962. C
  7963. C  RETRIEVE THE PASSWORDS.
  7964. C
  7965.       IF(EQ(RNAME,NAME)) GO TO 100
  7966.       GO TO 1500
  7967.   100 CONTINUE
  7968. C
  7969. C  COMPARE THE PASSWORDS.
  7970. C
  7971.       IF(JCODE.NE.1) GO TO 500
  7972. C
  7973. C  READ.
  7974. C
  7975.       IF(EQ(RPW,NONE)) GO TO 1000
  7976.       IF(EQ(RPW,USERID)) GO TO 1000
  7977.       IF(EQ(MPW,USERID)) GO TO 1000
  7978.       IF(EQ(OWNER,USERID)) GO TO 1000
  7979.       GO TO 1500
  7980.   500 CONTINUE
  7981.       IF(JCODE.NE.2) GO TO 1500
  7982. C
  7983. C  MODIFY.
  7984. C
  7985.       IF(EQ(MPW,NONE)) GO TO 1000
  7986.       IF(EQ(MPW,USERID)) GO TO 1000
  7987.       IF(EQ(OWNER,USERID)) GO TO 1000
  7988.       GO TO 1500
  7989. C
  7990. C  OK.
  7991. C
  7992.  1000 LOCPRM = 0
  7993.       RMSTAT = 0
  7994.       RETURN
  7995. C
  7996. C  NO WAY.
  7997. C
  7998.  1500 CONTINUE
  7999.       LOCPRM = 1
  8000.       RMSTAT = 90
  8001.       RETURN
  8002.       END
  8003.       FUNCTION LOCREL(RNAME)
  8004.         Include TEXT.BLK
  8005. C
  8006. C  PURPOSE:   LOOK FOR A RELATION IN THE RELTBL RELATION
  8007. C
  8008. C  PARAMETERS:
  8009. C         RNAME---NAME OF RELATION OR BLANK
  8010. C         LOCREL--STATUS VARIABLE - 0 MEANS OK, 1 MEANS NO WAY
  8011.         Include RELTBL.BLK
  8012.         Include TUPLER.BLK
  8013.         Include MISC.BLK
  8014.         Include RIMPTR.BLK
  8015.       LOGICAL EQ
  8016.         Include DCLAR1.BLK
  8017.         Include DATA2.BLK
  8018.       LOCREL = 0
  8019. C
  8020. C  SCAN FOR THIS RELATION.
  8021. C
  8022.       MRSTRT = MSTRTP
  8023.   100 CONTINUE
  8024.       CALL RELPAG(MRSTRT)
  8025.       I = MRSTRT
  8026.   200 CONTINUE
  8027.       IF(I.GT.RPBUF) GO TO 400
  8028.       IF(RELTBL(1,I).EQ.0) GO TO 9000
  8029.       IF(RELTBL(1,I).LT.0) GO TO 300
  8030.       IF(EQ(RNAME,BLANK)) GO TO 500
  8031.       IF(EQ(RELTBL(2,I),RNAME)) GO TO 500
  8032.   300 CONTINUE
  8033.       I = I + 1
  8034.       GO TO 200
  8035. C
  8036. C  GET THE NEXT PAGE.
  8037. C
  8038.   400 CONTINUE
  8039.       MRSTRT = RELBUF(1)
  8040.       IF(MRSTRT.EQ.0) GO TO 9000
  8041.       GO TO 100
  8042. C
  8043. C  FOUND IT.
  8044. C
  8045.   500 CONTINUE
  8046.       LRROW = I - 1
  8047.       CALL BLKMOV(NAME,RELTBL(2,I),2)
  8048.       CALL BLKMOV(RDATE,RELTBL(4,I),2)
  8049.       NCOL = RELTBL(6,I)
  8050.       NATT = RELTBL(7,I)
  8051.       NTUPLE = RELTBL(8,I)
  8052.       RSTART = RELTBL(9,I)
  8053.       REND = RELTBL(10,I)
  8054.       CALL BLKMOV(RPW,RELTBL(11,I),2)
  8055.       CALL BLKMOV(MPW,RELTBL(13,I),2)
  8056.       CNAME = RNAME
  8057. C
  8058. C  ALSO SET THE VALUES IN THE RIMPTR COMMON BLOCK.
  8059. C
  8060.       IVAL = 0
  8061.       LIMVAL = 0
  8062.       CID = RSTART
  8063.       NID = CID
  8064.       NS = 0
  8065.       MID = 0
  8066.       GO TO 9999
  8067. C
  8068. C  UNABLE TO FIND WHAT WE ARE LOOKING FOR.
  8069. C
  8070.  9000 CONTINUE
  8071.       LOCREL = 1
  8072.       LRROW = 0
  8073.  9999 CONTINUE
  8074.       RETURN
  8075.       END
  8076.       SUBROUTINE LODELE(NUMELE,ERROR)
  8077.         Include TEXT.BLK
  8078. C
  8079. C  THIS ROUTINE LOADS THE ELEMENT DATA INTO THE SCRATCH RELATION.
  8080. C
  8081. C  PARAMETERS:
  8082. C         NUMELE--NUMBER OF NEWLY DEFINED ATTRIBUTES
  8083. C         ERROR---COUNT OF CRUMMY INPUT COMMANDS
  8084. C
  8085.         Include RMATTS.BLK
  8086.         Include RMKEYW.BLK
  8087.         Include BUFFER.BLK
  8088.         Include FILES.BLK
  8089.         Include MISC.BLK
  8090.         Include CONST4.BLK
  8091. C
  8092.       LOGICAL EQKEYW
  8093.       INTEGER ERROR
  8094.       INTEGER ROWS
  8095.       INTEGER COLUMN
  8096. C
  8097. C  READ AN ELEMENT RECORD.
  8098. C
  8099.   100 CONTINUE
  8100.       CALL LODREC
  8101.       IF(LXITEM(IDUMMY).GT.1) GO TO 200
  8102.       IF(EQKEYW(1,KWELEM,8)) GO TO 999
  8103.       IF(EQKEYW(1,KWATTR,10)) GO TO 999
  8104.       IF(EQKEYW(1,KWRELA,9)) GO TO 999
  8105.       IF(EQKEYW(1,KWPASS,9)) GO TO 999
  8106.       IF(EQKEYW(1,KWRULS,5)) GO TO 999
  8107.       IF(EQKEYW(1,KWEND,3)) GO TO 999
  8108. C
  8109. C  UNRECOGNIZED GARBAGE.
  8110. C
  8111.       CALL WARN(4,0,0)
  8112.       ERROR = ERROR + 1
  8113.       GO TO 100
  8114. C
  8115. C  EDIT ELEMENT INPUT.
  8116. C
  8117.   200 CONTINUE
  8118.       IATTV = 0
  8119.       IF(EQKEYW(2,KWREAL,4)) IATTV = KZREAL
  8120.       IF(EQKEYW(2,KWTEXT,4)) IATTV = KZTEXT
  8121.       IF(EQKEYW(2,KWINT ,7)) IATTV = KZINT
  8122.       IF(EQKEYW(2,KWDOUB,6)) IATTV = KZDOUB
  8123.       IF(EQKEYW(2,KWRVEC,4)) IATTV = KZRVEC
  8124.       IF(EQKEYW(2,KWIVEC,4)) IATTV = KZIVEC
  8125.       IF(EQKEYW(2,KWDVEC,4)) IATTV = KZDVEC
  8126.       IF(EQKEYW(2,KWRMAT,4)) IATTV = KZRMAT
  8127.       IF(EQKEYW(2,KWIMAT,4)) IATTV = KZIMAT
  8128.       IF(EQKEYW(2,KWDMAT,4)) IATTV = KZDMAT
  8129.       IF(IATTV.NE.0) GO TO 300
  8130.       WRITE(NOUT,9000)
  8131.  9000 FORMAT(36H -ERROR- ILLEGAL DATA TYPE SPECIFIED)
  8132.       ERROR = ERROR + 1
  8133.       GO TO 100
  8134.   300 CONTINUE
  8135. C
  8136. C  MAKE SURE THAT THE ATTRIBUTE NAME IS TEXT.
  8137. C
  8138.       IF(LXID(1).EQ.KZTEXT) GO TO 400
  8139.       WRITE(NOUT,9001)
  8140.  9001 FORMAT(37H -ERROR- ATTRIBUTE NAMES MUST BE TEXT)
  8141.       ERROR = ERROR + 1
  8142.       GO TO 100
  8143.   400 CONTINUE
  8144.       IF(LXLENC(1).LE.8) GO TO 450
  8145.       CALL WARN(7,KWATTR,K4E)
  8146.       ERROR = ERROR + 1
  8147.       GO TO 100
  8148.   450 CONTINUE
  8149. C
  8150. C  LXITEM(IDUMMY) = 2, 3, 4, OR 5 ?
  8151. C
  8152.       LENGTH = 1
  8153.       IF(EQKEYW(2,KWTEXT,4)) LENGTH = 8
  8154.       ROWS = 1
  8155.       COLUMN = 1
  8156.       KEY = 0
  8157.       IF(LXITEM(IDUMMY).EQ.2) GO TO 700
  8158.       IF(LXITEM(IDUMMY).EQ.3) GO TO 500
  8159.       IF(LXITEM(IDUMMY).EQ.4) GO TO 600
  8160.       IF(LXITEM(IDUMMY).EQ.5) GO TO 600
  8161.       CALL WARN(4,0,0)
  8162.       ERROR = ERROR + 1
  8163.       GO TO 100
  8164. C
  8165. C  LXITEM(IDUMMY) = 3.
  8166. C
  8167.   500 CONTINUE
  8168.       IF(EQKEYW(3,KWKEY,3)) GO TO 540
  8169.       IF((LXIREC(3).GT.0).AND.(LXIREC(3).LE.MAXCOL)) GO TO 530
  8170.       IF(EQKEYW(3,KWVAR,3)) GO TO 550
  8171.       WRITE(NOUT,9002) MAXCOL
  8172.  9002 FORMAT(42H -ERROR- LENGTH MUST BE A POSITIVE INTEGER,
  8173.      X       18H IN THE RANGE 1 TO,I5)
  8174.       ERROR = ERROR + 1
  8175. C
  8176.   530 CONTINUE
  8177.       LENGTH = LXIREC(3)
  8178.       ROWS = LENGTH
  8179.       GO TO 700
  8180. C
  8181.   540 CONTINUE
  8182.       KEY = 1
  8183.       GO TO 700
  8184. C
  8185.   550 CONTINUE
  8186.       LENGTH = 0
  8187.       ROWS = 0
  8188.       COLUMN = 0
  8189.       GO TO 700
  8190. C
  8191. C  LXITEM(IDUMMY) = 4 OR 5.
  8192. C
  8193.   600 CONTINUE
  8194.       IF((LXID(3).EQ.KZINT).AND.(LXIREC(3).GT.0)) GO TO 620
  8195.       IF(EQKEYW(3,KWVAR,3)) GO TO 610
  8196.       WRITE(NOUT,9002) MAXCOL
  8197.       ERROR = ERROR + 1
  8198.       GO TO 100
  8199. C
  8200.   610 CONTINUE
  8201.       LENGTH = 0
  8202.       ROWS = 0
  8203.       GO TO 630
  8204. C
  8205.   620 CONTINUE
  8206.       LENGTH = LXIREC(3)
  8207.       ROWS = LENGTH
  8208.       IF((LXID(4).EQ.KZINT).AND.(LXIREC(4).GT.0)) GO TO 650
  8209.   630 CONTINUE
  8210.       IF(EQKEYW(4,KWKEY,3)) GO TO 640
  8211.       IF(EQKEYW(4,KWVAR,3)) GO TO 660
  8212.       CALL WARN(4,0,0)
  8213.       ERROR = ERROR + 1
  8214.       GO TO 100
  8215. C
  8216.   640 CONTINUE
  8217.       KEY = 1
  8218.       GO TO 700
  8219. C
  8220.   650 CONTINUE
  8221.       COLUMN = LXIREC(4)
  8222.       GO TO 670
  8223.   660 CONTINUE
  8224.       COLUMN = 0
  8225.   670 CONTINUE
  8226.       IF(EQKEYW(2,KWRMAT,4)) GO TO 680
  8227.       IF(EQKEYW(2,KWIMAT,4)) GO TO 680
  8228.       IF(EQKEYW(2,KWDMAT,4)) GO TO 680
  8229.       WRITE(NOUT,9003)
  8230.  9003 FORMAT(56H -ERROR- MATRIX DATA TYPE REQUIRED WITH ROWS AND COLUMNS
  8231.      X)
  8232.       ERROR = ERROR + 1
  8233.       GO TO 100
  8234. C
  8235.   680 CONTINUE
  8236.       IF(LXITEM(IDUMMY).EQ.4) GO TO 700
  8237.       IF(EQKEYW(5,KWKEY,3)) GO TO 640
  8238.       CALL WARN(4,0,0)
  8239.       ERROR = ERROR + 1
  8240.       GO TO 100
  8241. C
  8242. C  STORE THE ELEMENT IN JUNK.
  8243. C
  8244.   700 CONTINUE
  8245.       NUMELE = NUMELE + 1
  8246.       CALL BLKCHG(10,5,NUMELE)
  8247.       KQ1 = BLKLOC(10)
  8248.       KQ1 = KQ1 + (5*(NUMELE-1))
  8249.       BUFFER(KQ1) = IBLANK
  8250.       CALL LXSREC(1,1,8,BUFFER(KQ1),1)
  8251.       BUFFER(KQ1+2) = IATTV
  8252.       IF(EQKEYW(2,KWDOUB,6)) LENGTH = LENGTH * 2
  8253.       BUFFER(KQ1+3) = LENGTH
  8254.       BUFFER(KQ1+4) = KEY
  8255. C
  8256. C  GET MORE DATA.
  8257. C
  8258.       IF(BUFFER(KQ1+2).NE.KZTEXT) GO TO 750
  8259. C
  8260. C  SPECIAL PACKING FOR TEXT ATTRIBUTES.
  8261. C
  8262.       NWORDS = ((LENGTH - 1) / CHPWD) + 1
  8263.       IF(LENGTH.EQ.0) NWORDS = 0
  8264.  
  8265.       CALL HTOI(LENGTH,NWORDS,BUFFER(KQ1+3))
  8266.       GO TO 100
  8267. C
  8268.   750 CONTINUE
  8269.       IF(BUFFER(KQ1+2).EQ.KZINT ) GO TO 100
  8270.       IF(BUFFER(KQ1+2).EQ.KZREAL) GO TO 100
  8271.       IF(BUFFER(KQ1+2).EQ.KZDOUB) GO TO 100
  8272. C
  8273. C  PROCESS VECTOR AND MATRIX ITEMS.
  8274. C
  8275.       IF(BUFFER(KQ1+2).NE.KZDVEC) GO TO 760
  8276.       COLUMN = 2
  8277.       GO TO 770
  8278.   760 CONTINUE
  8279.       IF(BUFFER(KQ1+2).NE.KZDMAT) GO TO 770
  8280.       COLUMN = COLUMN * 2
  8281.   770 CONTINUE
  8282.       CALL HTOI(ROWS,ROWS*COLUMN,BUFFER(KQ1+3))
  8283.       GO TO 100
  8284. C
  8285. C  DONE.
  8286. C
  8287.   999 CONTINUE
  8288.       RETURN
  8289.       END
  8290.       SUBROUTINE LODPAS(ERROR)
  8291.         Include TEXT.BLK
  8292. C
  8293. C  THIS ROUTINE PROCESS THE PASSWORDS FOR RELATIONS WHEN DEFINING
  8294. C  A RIM SCHEMA.  PASSWORD COMMANDS MAY BE ABBREVIATED OR
  8295. C  INPUT IN A LONG FORM.  LOADPAS PERFORMS THE EDITING OF THE
  8296. C  USER INPUT.
  8297. C
  8298.         Include TUPLER.BLK
  8299.         Include RMKEYW.BLK
  8300.         Include FILES.BLK
  8301.         Include MISC.BLK
  8302.       INTEGER ERROR
  8303.       LOGICAL EQKEYW
  8304.         Include DCLAR1.BLK
  8305.         Include DCLAR3.BLK
  8306. C
  8307. C  READ A PASSWORD.
  8308. C
  8309.   100 CONTINUE
  8310.       CALL LODREC
  8311.       IF(EQKEYW(1,KWELEM,8)) GO TO 999
  8312.       IF(EQKEYW(1,KWATTR,10)) GO TO 999
  8313.       IF(EQKEYW(1,KWRELA,9)) GO TO 999
  8314.       IF(EQKEYW(1,KWPASS,9)) GO TO 100
  8315.       IF(EQKEYW(1,KWRULS,5)) GO TO 999
  8316.       IF(EQKEYW(1,KWEND,3)) GO TO 999
  8317.       ITEMS = LXITEM(IDUMMY)
  8318.       IF(ITEMS.EQ.5) GO TO 200
  8319.       IF(ITEMS.EQ.6) GO TO 300
  8320.       CALL WARN(4,0,0)
  8321.       ERROR = ERROR + 1
  8322.       GO TO 100
  8323. C
  8324. C  ABBREVIATED FORMAT FOR PASSWORD COMMAND.
  8325. C
  8326.   200 CONTINUE
  8327.       ICODE = 1
  8328.       IF(EQKEYW(1,KWRPW,3)) ICODE = 2
  8329.       IF(EQKEYW(1,KWMPW,3)) ICODE = 3
  8330.       IF(ICODE.NE.1) GO TO 220
  8331. C
  8332. C  ERROR IN PASSWORD SYNTAX.
  8333. C
  8334.   215 CONTINUE
  8335.       CALL WARN(4,0,0)
  8336.       ERROR = ERROR + 1
  8337.       GO TO 100
  8338. C
  8339.   220 CONTINUE
  8340.       IF(EQKEYW(2,KWFOR,3)) GO TO 230
  8341.       CALL WARN(4,0,0)
  8342.       ERROR = ERROR + 1
  8343.       GO TO 100
  8344. C
  8345.   230 CONTINUE
  8346.       RNAME = BLANK
  8347.       IF(.NOT.EQKEYW(3,KWALL,3)) CALL LXSREC(3,1,8,RNAME,1)
  8348.       I = LOCREL(RNAME)
  8349.       IF(I.EQ.0) GO TO 240
  8350.       CALL WARN(1,RNAME,0)
  8351.       ERROR = ERROR + 1
  8352.       GO TO 100
  8353. C
  8354.   240 CONTINUE
  8355.       IF(EQKEYW(4,KWIS,2)) GO TO 400
  8356.       CALL WARN(4,0,0)
  8357.       ERROR = ERROR + 1
  8358.       GO TO 100
  8359. C
  8360. C  LONG VERSION FOR PASSWORD COMMAND.
  8361. C
  8362.   300 CONTINUE
  8363.       ICODE = 1
  8364.       IF(EQKEYW(1,KWREAD,4)) ICODE = 2
  8365.       IF(EQKEYW(1,KWMODI,6)) ICODE = 3
  8366.       IF(ICODE.NE.1) GO TO 330
  8367. C
  8368.   320 CONTINUE
  8369.       CALL WARN(4,0,0)
  8370.       ERROR = ERROR + 1
  8371.       GO TO 100
  8372. C
  8373.   330 CONTINUE
  8374.       IF(EQKEYW(2,KWPASS,8)) GO TO 340
  8375.       CALL WARN(4,0,0)
  8376.       ERROR = ERROR + 1
  8377.       GO TO 100
  8378. C
  8379.   340 CONTINUE
  8380.       IF(EQKEYW(3,KWFOR,3)) GO TO 350
  8381.       CALL WARN(4,0,0)
  8382.       ERROR = ERROR + 1
  8383.       GO TO 100
  8384. C
  8385.   350 CONTINUE
  8386.       RNAME = BLANK
  8387.       IF(.NOT.EQKEYW(4,KWALL,3)) CALL LXSREC(4,1,8,RNAME,1)
  8388.       I = LOCREL(RNAME)
  8389.       IF(I.EQ.0) GO TO 360
  8390.       CALL WARN(1,RNAME,0)
  8391.       ERROR = ERROR + 1
  8392.       GO TO 100
  8393. C
  8394.   360 CONTINUE
  8395.       IF(EQKEYW(5,KWIS,2)) GO TO 400
  8396.       CALL WARN(4,0,0)
  8397.       ERROR = ERROR + 1
  8398.       GO TO 100
  8399. C
  8400. C  STORE THE PASSWORD.
  8401. C
  8402.   400 CONTINUE
  8403.       IF(ICODE.EQ.1) GO TO 100
  8404.   500 CONTINUE
  8405.       CALL RELGET(ISTAT)
  8406.       IF(ISTAT.NE.0) GO TO 100
  8407.       IF((LXLENC(ITEMS).GE.1).AND.(LXLENC(ITEMS).LE.8)) GO TO 600
  8408.       WRITE(NOUT,550)
  8409.   550 FORMAT(44H -ERROR- PASSWORDS MUST BE 1-8 ALPHANUMERIC ,
  8410.      X       10HCHARACTERS)
  8411.       ERROR = ERROR + 1
  8412.       GO TO 100
  8413.   600 CONTINUE
  8414.       RPW1 = BLANK
  8415.       CALL LXSREC(ITEMS,1,8,RPW1,1)
  8416.       IF(ICODE.EQ.2) RPW= RPW1
  8417.       IF(ICODE.EQ.3) MPW = RPW1
  8418.       CALL RELPUT
  8419. C
  8420. C  LOOK FOR MORE RELATIONS.
  8421. C
  8422.       GO TO 500
  8423. C
  8424. C  END PASSWORD PROCESSING.
  8425. C
  8426.   999 CONTINUE
  8427.       RETURN
  8428.       END
  8429.       SUBROUTINE LODREC
  8430.         Include TEXT.BLK
  8431. C
  8432. C     COVER ROUTINE FOR LXLREC WHICH HANDLES END-OF-FILES.
  8433. C
  8434.         Include LXGEN.BLK
  8435.         Include RMATTS.BLK
  8436.         Include RMKEYW.BLK
  8437.         Include CONST4.BLK
  8438.         Include CONST8.BLK
  8439.         Include FLAGS.BLK
  8440.         Include FILES.BLK
  8441.         Include RIMCOM.BLK
  8442.         Include MISC.BLK
  8443.       LOGICAL EQKEYW
  8444.         Include DCLAR4.BLK
  8445.       IF(RMSTAT.GT.1000) GO TO 800
  8446.       NUMEOF = 0
  8447.       IF(ECHO.AND.(NUMREP.EQ.0)) WRITE(NOUTR,10)
  8448.    10 FORMAT(1X)
  8449.     1 CONTINUE
  8450.       IF(NUMEOF.GT.10) GO TO 820
  8451.       LENREC = 0
  8452.       CALL LXLREC(DUM,LENREC,DUM)
  8453.       IF(LXID(1).NE.K4EOF) GO TO 100
  8454.       NUMEOF = NUMEOF + 1
  8455.       IF(BATCH) GO TO 900
  8456.       IF(CONNI) GO TO 1
  8457.       CALL SETIN(K8IN)
  8458.       GO TO 1
  8459.   100 CONTINUE
  8460.       ITEMS = LXITEM(DUM)
  8461.       ISAVE = LSTCMD
  8462.       CALL LXSREC(1,1,3,LSTCMD,1)
  8463.       IF(ITEMS.GT.3) GO TO 1000
  8464.       IF(EQKEYW(1,KWHELP,4)) GO TO 200
  8465.       IF(ITEMS.GT.2) GO TO 1000
  8466.       IF(EQKEYW(1,KWECHO,4)) GO TO 300
  8467.       IF(EQKEYW(1,KWNOEC,6)) GO TO 400
  8468.       IF(EQKEYW(1,KWINPU,5)) GO TO 500
  8469.       IF(EQKEYW(1,KWOUTP,6)) GO TO 600
  8470.       IF(EQKEYW(1,KWQUIT,4)) GO TO 700
  8471.       GO TO 1000
  8472.   200 CONTINUE
  8473. C
  8474. C     HELP
  8475. C
  8476.       IF((ITEMS.GE.2).AND.(LXID(2).NE.KZTEXT)) GO TO 1000
  8477.       IF((ITEMS.GE.3).AND.(LXID(3).NE.KZTEXT)) GO TO 1000
  8478.       LSTCMD = ISAVE
  8479.       CALL RMHELP
  8480.       GO TO 1
  8481.   300 CONTINUE
  8482. C
  8483. C     ECHO
  8484. C
  8485.       IF(ITEMS.EQ.2) GO TO 1000
  8486.       ECHO = .TRUE.
  8487.       CALL LXSET(KWECHO,K4ON)
  8488.       GO TO 1
  8489.   400 CONTINUE
  8490. C
  8491. C     NOECHO
  8492. C
  8493.       IF(ITEMS.EQ.2) GO TO 1000
  8494.       ECHO = .FALSE.
  8495.       CALL LXSET(KWECHO,K4OFF)
  8496.       GO TO 1
  8497.   500 CONTINUE
  8498. C
  8499. C     INPUT
  8500. C
  8501.       IF(ITEMS.NE.2) GO TO 1000
  8502.       IF(LXID(2).NE.KZTEXT) GO TO 1000
  8503.       IFILE = BLANK
  8504.       CALL LXSREC(2,1,7,IFILE,1)
  8505.       IF(EQKEYW(2,KWTERM,8))IFILE = K8IN
  8506.       CALL SETIN(IFILE)
  8507.       GO TO 1
  8508.   600 CONTINUE
  8509. C
  8510. C     OUTPUT
  8511. C
  8512.       IF(ITEMS.NE.2) GO TO 1000
  8513.       IF(LXID(2).NE.KZTEXT) GO TO 1000
  8514.       IFILE = BLANK
  8515.       CALL LXSREC(2,1,7,IFILE,1)
  8516.       IF(EQKEYW(2,KWTERM,8))IFILE = K8OUT
  8517.       CALL SETOUT(IFILE)
  8518.       GO TO 1
  8519.   700 CONTINUE
  8520. C
  8521. C     QUIT
  8522. C
  8523.       IF(ITEMS.EQ.2) GO TO 1000
  8524.       CALL RMCLOS
  8525.       GO TO 999
  8526. C
  8527. C  SYSTEM TYPE FILE/BUFFER ERRORS -- HELP???????????
  8528. C
  8529.   800 CONTINUE
  8530.       WRITE(NOUT,810) RMSTAT
  8531.   810 FORMAT(/,13H SYSTEM ERROR,I5,/)
  8532.       GO TO 900
  8533.   820 CONTINUE
  8534. C
  8535. C     TOO MANY END-OF-FILES ENCOUNTERED
  8536. C
  8537.       WRITE (NOUT,830)
  8538.   830 FORMAT(45H -WARNING- END-OF-FILE ENCOUNTERED ON "INPUT",/,
  8539.      X       11X,28HTHE DATABASE FILES ARE LOCAL,/)
  8540.       GO TO 900
  8541.   900 CONTINUE
  8542.       CALL RMCLOS
  8543.   999 CONTINUE
  8544.       STOP
  8545.  1000 CONTINUE
  8546.       RETURN
  8547.       END
  8548.       SUBROUTINE LODREL(NUMELE,ERROR)
  8549.         Include TEXT.BLK
  8550. C
  8551. C  THIS ROUTINE LOADS THE RELATION DESCRIPTION FROM USER DIRECTIVES
  8552. C  IN THE APPROPRIATE RIM TABLES BASED ON THE CSC SCHEMA DEFINITION.
  8553. C  A ROUTINE (CHEQLST) DOES THE ACTUAL DATA TRANSFER
  8554. C  WITH THIS ROUTINE PERFORMING THE MAJORITY OF THE EDITING.
  8555. C
  8556.         Include RMATTS.BLK
  8557.         Include RMKEYW.BLK
  8558.         Include BUFFER.BLK
  8559.         Include FILES.BLK
  8560.         Include MISC.BLK
  8561. C
  8562.       LOGICAL EQKEYW
  8563.       INTEGER ERROR
  8564.         Include DCLAR1.BLK
  8565. C
  8566. C  READ RELATION DATA.
  8567. C
  8568.   100 CONTINUE
  8569.       CALL LODREC
  8570.       IF(LXITEM(IDUMMY).GT.1) GO TO 150
  8571.       IF(EQKEYW(1,KWELEM,8)) GO TO 999
  8572.       IF(EQKEYW(1,KWATTR,10)) GO TO 999
  8573.       IF(EQKEYW(1,KWRELA,9)) GO TO 999
  8574.       IF(EQKEYW(1,KWPASS,9)) GO TO 999
  8575.       IF(EQKEYW(1,KWRULS,5)) GO TO 999
  8576.       IF(EQKEYW(1,KWEND,3)) GO TO 999
  8577.   150 CONTINUE
  8578.       IF(LXITEM(IDUMMY).GE.3) GO TO 200
  8579. C
  8580. C  UNRECOGNIZED GARBAGE.
  8581. C
  8582.       CALL WARN(4,0,0)
  8583.       ERROR = ERROR + 1
  8584.       GO TO 100
  8585. C
  8586. C  CHECK FOR VALID RELATION NAME.
  8587. C
  8588.   200 CONTINUE
  8589.       IF(LXID(1).EQ.KZTEXT) GO TO 300
  8590.       WRITE(NOUT,9000)
  8591.  9000 FORMAT(36H -ERROR- RELATION NAMES MUST BE TEXT)
  8592.       ERROR = ERROR + 1
  8593.       GO TO 100
  8594.   300 CONTINUE
  8595.       IF(LXLENC(1).LE.8) GO TO 400
  8596.       CALL WARN(7,KWRELA,BLANK)
  8597.       ERROR = ERROR + 1
  8598.       GO TO 100
  8599.   400 CONTINUE
  8600.       RNAME = BLANK
  8601.       CALL LXSREC(1,1,8,RNAME,1)
  8602.       I = LOCREL(RNAME)
  8603.       IF(I.NE.0) GO TO 500
  8604.       WRITE(NOUT,9001)
  8605.  9001 FORMAT(44H -ERROR- DUPLICATE RELATION NAME ENCOUNTERED)
  8606.       ERROR = ERROR + 1
  8607.       GO TO 100
  8608. C
  8609. C  CHECK ATTRIBUTE NAMES.
  8610. C
  8611.   500 CONTINUE
  8612.       JUNK = 1
  8613.       IF(NUMELE.GT.0) JUNK = BLKLOC(10)
  8614.       CALL CHKATT(BUFFER(JUNK),NUMELE,ERROR)
  8615.       GO TO 100
  8616. C
  8617. C  END RELATION PROCESSING.
  8618. C
  8619.   999 CONTINUE
  8620.       RETURN
  8621.       END
  8622.       SUBROUTINE LODRUL
  8623.         Include TEXT.BLK
  8624. C
  8625. C  THIS ROUTINE PROCESSES THE RULES OF A RIM SCHEMA.  THE
  8626. C  ACTUAL PARSING OF THE RULES IS DONE IN THIS ROUTINE.  THE
  8627. C  ROUTINE SETRUL SETS UP THE APPROPRIATE RELATIONS TO STORE THE
  8628. C  RULES.
  8629. C
  8630.         Include RMATTS.BLK
  8631.         Include RMKEYW.BLK
  8632.         Include CONST4.BLK
  8633.         Include RIMCOM.BLK
  8634.         Include RIMPTR.BLK
  8635.         Include WHCOM.BLK
  8636.         Include CONST8.BLK
  8637.         Include TUPLER.BLK
  8638.         Include RULCOM.BLK
  8639.         Include TUPLEA.BLK
  8640.         Include MISC.BLK
  8641.         Include BUFFER.BLK
  8642.         Include FILES.BLK
  8643.         Include DCLAR1.BLK
  8644.       INTEGER RTBL(24)
  8645.       INTEGER ITEM
  8646.       INTEGER VALUE(10)
  8647.       REAL RVALUE(10)
  8648.       EQUIVALENCE (RVALUE(1),VALUE(1))
  8649.       EQUIVALENCE (RTBL(2),ANAME)
  8650.       EQUIVALENCE (RTBL(4),ANAME1)
  8651.       EQUIVALENCE (RTBL(6),RNAME1)
  8652.       EQUIVALENCE (RTBL(8),IBOO)
  8653.       EQUIVALENCE (RTBL(10),ITEM)
  8654.       EQUIVALENCE (RTBL(11),ANAME2)
  8655.       EQUIVALENCE (RTBL(13),RNAME2)
  8656.       EQUIVALENCE (RTBL(15),VALUE(1))
  8657.       INTEGER RRC(3)
  8658.       LOGICAL EQKEYW
  8659.       LOGICAL EQ
  8660.       LOGICAL NE
  8661.       NERROR = 0
  8662. C
  8663. C  LOOK FOR EXISTING RULES.
  8664. C
  8665.       I = LOCREL(RIMRRC)
  8666.       IF(I.NE.0) GO TO 50
  8667.       NUMRUL = 0
  8668.       IF(NTUPLE.EQ.0) GO TO 40
  8669.       ID = REND
  8670.       CALL GETDAT(1,ID,LOC,LENGTH)
  8671.       NUMRUL = BUFFER(LOC+2)
  8672.    40 CONTINUE
  8673.       I = LOCREL(RIMRDT)
  8674.       IF(I.EQ.0) GO TO 100
  8675.    50 CONTINUE
  8676. C
  8677. C  SET UP RIMRRC AND RIMRDT FOR THE FIRST TIME.
  8678. C
  8679.       CALL SETRUL
  8680.       NUMRUL = 0
  8681. C
  8682. C  READ THE RULES.
  8683. C
  8684.   100 CONTINUE
  8685. C
  8686. C  DELETE RULE IF THERE WAS AN ERROR
  8687. C
  8688.       RNAME = RIMRRC
  8689.  2000 CONTINUE
  8690.       IF(NERROR.LE.0) GO TO 2050
  8691. C
  8692. C  LOCATE RELATION AND SET UP THE WHERE CLAUSE FOR RULE NUMBER
  8693. C
  8694.       I = LOCREL(RNAME)
  8695.       I = LOCATT(K8NUM,RNAME)
  8696.       CALL ATTGET(I)
  8697.       NBOO = 1
  8698.       BOO(1) = K4AND
  8699.       KATTP(1) = ATTCOL
  8700.       KATTL(1) = ATTLEN
  8701.       KATTY(1) = ATTYPE
  8702.       KOMTYP(1) = 2
  8703.       KOMPOS(1) = 1
  8704.       KOMLEN(1) = 1
  8705.       KOMPOT(1) = 1
  8706.       KSTRT = 0
  8707.       MAXTU = ALL9S
  8708.       LIMTU = ALL9S
  8709.       WHRVAL(1) = NUMRUL
  8710.       WHRLEN(1) = 1
  8711.       NS = 0
  8712.       IF(NTUPLE.LE.0) GO TO 2030
  8713.       IID = CID
  8714.       ND = 0
  8715. C
  8716. C  LOCATE AND DE-LINK THE EFFECTED TUPLES
  8717. C
  8718.  2010 CONTINUE
  8719.       CALL RMLOOK(MAT,1,1,LENGTH)
  8720.       IF(RMSTAT.NE.0) GO TO 2020
  8721.       ND = ND + 1
  8722.       CALL DELDAT(1,CID)
  8723.       IF(CID.EQ.IID) IID = NID
  8724.       GO TO 2010
  8725.  2020 CONTINUE
  8726.       IF(ND.EQ.0) GO TO 2030
  8727.       CALL RELGET(LENGTH)
  8728.       RSTART = IID
  8729.       NTUPLE = NTUPLE - ND
  8730.       CALL RELPUT
  8731.  2030 RMSTAT = 0
  8732.       RNAME = RIMRDT
  8733.       NERROR = NERROR - 1
  8734.       IF(NERROR.EQ.1) GO TO 2000
  8735.       NUMRUL = NUMRUL - 1
  8736.  2050 CONTINUE
  8737.       CALL LODREC
  8738.       ITEMS = LXITEM(I)
  8739.       IF(EQKEYW(1,KWELEM,8)) GO TO 999
  8740.       IF(EQKEYW(1,KWRELA,9)) GO TO 999
  8741.       IF(EQKEYW(1,KWATTR,10)) GO TO 999
  8742.       IF(EQKEYW(1,KWPASS,9)) GO TO 999
  8743.       IF(EQKEYW(1,KWRULS,5)) GO TO 999
  8744.       IF(EQKEYW(1,KWEND,3)) GO TO 999
  8745. C
  8746. C  PROCESS THIS RULE.
  8747. C
  8748.   110 CONTINUE
  8749.       ANAME = K8AND
  8750.       J = 1
  8751.       IFLAG = 0
  8752.       NUMRUL = NUMRUL + 1
  8753.       ANAME1 = BLANK
  8754.       CALL LXSREC(1,1,8,ANAME1,1)
  8755.       RNAME1 = BLANK
  8756.       IF(.NOT.EQKEYW(2,KWIN,2)) GO TO 200
  8757. C
  8758. C  RELATION NAME IS SPECIFIED.
  8759. C
  8760.       CALL LXSREC(3,1,8,RNAME1,1)
  8761.       RNAME = RNAME1
  8762.       I = LOCATT(ANAME1,RNAME1)
  8763.       IF(I.NE.0) GO TO 150
  8764.       CALL ATTGET(ISTAT)
  8765.       GO TO 400
  8766.   150 CONTINUE
  8767.       CALL WARN(3,ANAME1,RNAME1)
  8768.       NUMRUL = NUMRUL - 1
  8769.       GO TO 100
  8770.   200 CONTINUE
  8771. C
  8772. C  ANY RELATION WITH THIS ATTRIBUTE.
  8773. C
  8774.       I = LOCATT(ANAME1,RNAME1)
  8775.       IF(I.NE.0) GO TO 150
  8776.   300 CONTINUE
  8777.       IF(EQKEYW(2,KWIN,2)) GO TO 100
  8778.       CALL ATTGET(ISTAT)
  8779.       IF(ISTAT.NE.0) GO TO 100
  8780.       RNAME = RELNAM
  8781.       IFLAG = IFLAG + 1
  8782.   400 CONTINUE
  8783. C
  8784. C  MAKE AN ADDITION TO RIMRRC.
  8785. C
  8786.       RRC(1) = IBLANK
  8787.       RRC(2) = IBLANK
  8788.       CALL STRMOV(RNAME,1,8,RRC,1)
  8789.       RRC(3) = NUMRUL
  8790.       I = LOCREL(RIMRRC)
  8791.       CALL RELGET(ISTAT)
  8792.       CALL ADDDAT(1,REND,RRC,3)
  8793.       IF(RSTART.EQ.0) RSTART = REND
  8794.       CALL RMDATE(RDATE)
  8795.       NTUPLE = NTUPLE + 1
  8796.       CALL RELPUT
  8797. C
  8798. C  PROCESS THE RULE.
  8799. C
  8800.   500 CONTINUE
  8801.       IF(J.GT.ITEMS) GO TO 300
  8802.       ANAME1 = BLANK
  8803.       CALL LXSREC(J,1,8,ANAME1,1)
  8804.       RNAME3 = BLANK
  8805.       IF(.NOT.EQKEYW(J+1,KWIN,2)) GO TO 510
  8806.       J = J + 2
  8807.       CALL LXSREC(J,1,8,RNAME3,1)
  8808.   510 CONTINUE
  8809.       IF(RNAME1.EQ.RNAME3) GO TO 530
  8810.       WRITE(NOUT,520)
  8811.   520 FORMAT(43H -ERROR- RULE COMPONENTS MUST APPLY TO THE ,
  8812.      X   13HSAME RELATION )
  8813.       NERROR = 2
  8814.       GO TO 100
  8815.   530 CONTINUE
  8816.       I = LOCATT(ANAME1,RNAME)
  8817.       IF(I.EQ.0) GO TO 600
  8818.       CALL WARN(3,ANAME1,RNAME)
  8819.       NERROR = 2
  8820.       GO TO 100
  8821.   600 CONTINUE
  8822.       CALL ATTGET(ISTAT)
  8823.       J = J + 1
  8824.       IBOO = IBLANK
  8825.       CALL LXSREC(J,1,4,IBOO,1)
  8826.       I = LOCBOO(IBOO)
  8827.       IF(I.NE.0) GO TO 700
  8828.       WRITE(NOUT,9000)
  8829.  9000 FORMAT(41H -ERROR- UNRECOGNIZED BOOLEAN COMPARISION )
  8830.       NERROR = 2
  8831.       GO TO 100
  8832.   700 CONTINUE
  8833.       J = J + 1
  8834.       ANAME2 = BLANK
  8835.       RNAME2 = BLANK
  8836.       IF(I.LT.10) GO TO 750
  8837. C
  8838. C  ATTRIBUTE COMPARISION.
  8839. C
  8840.       CALL HTOI(0,3,ITEM)
  8841.       CALL LXSREC(J,1,8,ANAME2,1)
  8842.       IF(.NOT.EQKEYW(J+1,KWIN,2)) GO TO 1000
  8843.       IF(.NOT.EQKEYW(2,KWIN,2)) GO TO 1000
  8844.       CALL LXSREC(J+2,1,8,RNAME2,1)
  8845.       LTYPE = ATTYPE
  8846.       LLEN = ATTLEN
  8847.       DO 705 K=1,10
  8848.       VALUE(K) = IBLANK
  8849.   705 CONTINUE
  8850.       J = J + 2
  8851.       I = LOCATT(ANAME2,RNAME2)
  8852.       IF(I.NE.0) GO TO 740
  8853.       CALL ATTGET(ISTAT)
  8854.       IF((LTYPE.NE.KZTEXT).AND.(LLEN.GT.1)) GO TO 720
  8855.       IF((LTYPE.EQ.ATTYPE) .AND. (LLEN.EQ.ATTLEN)) GO TO 800
  8856.       WRITE (NOUT,710)
  8857.   710 FORMAT(51H -ERROR- ATTRIBUTES MUST BE OF THE SAME TYPE/LENGTH)
  8858.       NERROR = 2
  8859.       GO TO 100
  8860.   720 CONTINUE
  8861.       WRITE(NOUT,730)
  8862.   730 FORMAT(48H -ERROR- NON-TEXT ATTRIBUTES MUST BE OF LENGTH 1)
  8863.       NERROR = 2
  8864.       GO TO 100
  8865.   740 CONTINUE
  8866.       CALL WARN(3,ANAME2,RNAME2)
  8867.       NERROR = 2
  8868.       GO TO 100
  8869. C
  8870. C  VALUE COMPARISION.
  8871. C
  8872.   750 CONTINUE
  8873.       IF(LXID(J).EQ.KZTEXT) K = 0
  8874.       IF(LXID(J).EQ.KZINT) K = 1
  8875.       IF(LXID(J).EQ.KZREAL) K = 2
  8876.       I = 0
  8877.       IF(K.EQ.0) I = LXLENC(J)
  8878. C
  8879. C  CHECK APPROPRIENESS OF VALUES
  8880. C
  8881.       LOP = (40-1)/CHPWD + 1
  8882.       IF(K.NE.0) GO TO 770
  8883. C
  8884. C  TEXT
  8885. C
  8886.       IF(ATTYPE.NE.KZTEXT) GO TO 790
  8887.       IF(I.LE.40) GO TO 764
  8888.       I = 40
  8889.       WRITE(NOUT,762)
  8890.   762 FORMAT(50H -WARNING- RULE "VALUE" TRUNCATED TO 40 CHARACTERS )
  8891.   764 CONTINUE
  8892.       CALL HTOI(I,K,ITEM)
  8893.       CALL LXSREC(J,1,40,VALUE,1)
  8894.       GO TO 800
  8895. C
  8896. C  INTEGER
  8897. C
  8898.   770 CONTINUE
  8899.       IF(K.NE.1) GO TO 780
  8900.       IF(ATTYPE.NE.KZINT) GO TO 790
  8901.       IF(ATTLEN.NE.1) GO TO 790
  8902.       ITEM = K
  8903.       DO 772 KK=2,LOP
  8904.   772 VALUE(KK) = 0
  8905.       VALUE(1) = LXIREC(J)
  8906.       GO TO 800
  8907. C
  8908. C  REAL/DOUBLE
  8909. C
  8910.   780 CONTINUE
  8911.       IF((ATTYPE.NE.KZREAL).AND.(ATTYPE.NE.KZDOUB)) GO TO 790
  8912.       IF((ATTYPE.EQ.KZREAL).AND.(ATTLEN.NE.1)) GO TO 790
  8913.       IF((ATTYPE.EQ.KZDOUB).AND.(ATTLEN.NE.2)) GO TO 790
  8914.       ITEM = K
  8915.       DO 782 KK=2,LOP
  8916.   782 RVALUE(KK) = 0.
  8917.       RVALUE(1) = RXREC(J)
  8918.       GO TO 800
  8919. C
  8920. C  INCOMPATABLE VALUE/ATTRIBUTE
  8921. C
  8922.   790 CONTINUE
  8923.       WRITE(NOUT,792)
  8924.   792 FORMAT(29H -ERROR- ILLEGAL RULE "VALUE" )
  8925.       NERROR = 2
  8926.       GO TO 100
  8927.   800 CONTINUE
  8928.       IF((.NOT.EQKEYW(2,KWIN,2)).AND.(IFLAG.NE.1)) GO TO 500
  8929. C
  8930. C  LOAD THIS RULE.
  8931. C
  8932.       RTBL(1) = NUMRUL
  8933.       I = LOCREL(RIMRDT)
  8934.       CALL RELGET(ISTAT)
  8935.       I = 14 + ((40-1)/CHPWD + 1)
  8936.       CALL ADDDAT(1,REND,RTBL,I)
  8937.       IF(RSTART.EQ.0) RSTART = REND
  8938.       CALL RMDATE(RDATE)
  8939.       NTUPLE = NTUPLE + 1
  8940.       CALL RELPUT
  8941.       IF(J+1.GT.ITEMS) GO TO 900
  8942.       CALL LXSREC(J+1,1,8,ANAME,1)
  8943.       IF(EQ(ANAME,K8AND)) GO TO 900
  8944.       IF(EQ(ANAME,K8OR)) GO TO 900
  8945.       WRITE(NOUT,9001)
  8946.  9001 FORMAT(55H -ERROR- RULES MUST BE JOINED WITH EITHER "AND" OR "OR")
  8947.       NERROR = 2
  8948.       GO TO 100
  8949.   900 CONTINUE
  8950.       J = J + 2
  8951.       GO TO 500
  8952. C
  8953. C  SYNTAX ERRORS.
  8954. C
  8955.  1000 CONTINUE
  8956.       WRITE(NOUT,9002)
  8957.  9002 FORMAT(48H -ERROR- RELATION MUST BE SPECIFIED IN THIS RULE)
  8958.       NERROR = 2
  8959.       GO TO 100
  8960. C
  8961. C  DONE SETTING UP RULES.
  8962. C
  8963.   999 CONTINUE
  8964. C
  8965. C  MAKE SURE THE USER ENTERED A KEYWORD - IF ITEMS GT 1 ASSUME A RULE
  8966. C
  8967.       IF(ITEMS.NE.1) GO TO 110
  8968.       RETURN
  8969.       END
  8970.       SUBROUTINE LSTREL
  8971.         Include TEXT.BLK
  8972. C
  8973. C  THIS ROUTINE SUMMARIZES THE USERS DEFINITION OF A RELATION
  8974. C
  8975. C
  8976.         Include RMATTS.BLK
  8977.         Include RMKEYW.BLK
  8978.         Include CONST4.BLK
  8979.         Include CONST8.BLK
  8980.         Include FLAGS.BLK
  8981.         Include MISC.BLK
  8982.         Include TUPLER.BLK
  8983.         Include TUPLEA.BLK
  8984.         Include FILES.BLK
  8985.       INTEGER STATUS
  8986.       LOGICAL EQ
  8987.       LOGICAL NE
  8988.       LOGICAL EQKEYW
  8989.       INTEGER IRPW
  8990.       INTEGER IMPW
  8991.         Include DCLAR1.BLK
  8992.         Include DCLAR6.BLK
  8993.       ITEMS = LXITEM(DUM)
  8994.       CALL RMDATE(IDAY)
  8995.       CALL RMTIME(ITIME)
  8996.       I = LOCREL(BLANK)
  8997.       NP = 0
  8998.       IF(I.EQ.0) GO TO 100
  8999.       WRITE(NOUT,20)
  9000.    20 FORMAT(32H -WARNING- RELATION TABLES EMPTY ,/)
  9001.       GO TO 9999
  9002.   100 CONTINUE
  9003.       IF(ITEMS.GT.2) GO TO 8200
  9004.       IF(ITEMS.EQ.2) GO TO 1000
  9005. C
  9006. C   LISTREL (WITH NO RELATION SPECIFIED)
  9007. C
  9008.       CALL RELGET(STATUS)
  9009.       IF(STATUS.NE.0) GO TO 900
  9010. C
  9011. C     DONT LISTREL RULE RELATIONS
  9012. C
  9013.       IF(EQ(NAME,K8RDT)) GO TO 100
  9014.       IF(EQ(NAME,K8RRC)) GO TO 100
  9015. C
  9016. C   VALIDATE USER
  9017. C
  9018.       IF(EQ(USERID,OWNER)) GO TO 150
  9019.       IF(EQ(RPW,NONE)) GO TO 150
  9020.       IF(EQ(RPW,USERID)) GO TO 150
  9021.       IF(EQ(MPW,USERID)) GO TO 150
  9022.       GO TO 100
  9023.   150 CONTINUE
  9024.       IF(NP.EQ.1) GO TO 200
  9025. C
  9026. C     WRITE OUT HEADER
  9027. C
  9028.       WRITE(NOUTR,160) IDAY,ITIME
  9029.   160 FORMAT(10X,25HEXISTING RELATIONS AS OF ,A8,3X,A8/)
  9030.       NP = 1
  9031.   200 CONTINUE
  9032.       WRITE(NOUTR,220) NAME
  9033.   220 FORMAT(20X,A8)
  9034.       GO TO 100
  9035.   900 CONTINUE
  9036.       IF(NP.EQ.0) WRITE(NOUT,1260)
  9037.       GO TO 9999
  9038.  1000 CONTINUE
  9039. C
  9040. C   LISTREL RELATION
  9041. C
  9042.       IF(.NOT.EQKEYW(2,KWALL,3)) GO TO 1050
  9043.       I = LOCREL(BLANK)
  9044.       IF(I.NE.0) GO TO 8000
  9045.       NREL = 0
  9046.       GO TO 1100
  9047.  1050 CONTINUE
  9048.       RNAME = BLANK
  9049.       CALL LXSREC(2,1,8,RNAME,1)
  9050.       I = LOCREL(RNAME)
  9051.       IF(I.EQ.0) GO TO 1100
  9052. C
  9053. C  REQUESTED RELATION DOES NOT EXIST
  9054. C
  9055.       CALL WARN(1,RNAME,0)
  9056.       GO TO 9999
  9057.  1100 CONTINUE
  9058.       IF(.NOT.EQKEYW(2,KWALL,3)) GO TO 1200
  9059.       CALL RELGET(STATUS)
  9060.       IF((NREL.EQ.0).AND.(STATUS.NE.0)) GO TO 8100
  9061.       IF(STATUS.NE.0) GO TO 9999
  9062.  1200 CONTINUE
  9063. C
  9064. C     DONT LISTREL RULE RELATIONS
  9065. C
  9066.       IF(EQ(NAME,K8RDT)) GO TO 1250
  9067.       IF(EQ(NAME,K8RRC)) GO TO 1250
  9068. C
  9069. C   CHECK PERMISSION
  9070. C
  9071.       IF(EQ(USERID,OWNER)) GO TO 1300
  9072.       IF(EQ(RPW,NONE)) GO TO 1300
  9073.       IF(EQ(RPW,USERID)) GO TO 1300
  9074.       IF(EQ(MPW,USERID)) GO TO 1300
  9075.  1250 CONTINUE
  9076.       IF(EQKEYW(2,KWALL,3)) GO TO 1100
  9077.       WRITE(NOUT,1260)
  9078.  1260 FORMAT(40H -ERROR- UNAUTHORIZED ACCESS TO RELATION ,
  9079.      X       20H DATA NOT PERMITTED. )
  9080.       GO TO 9999
  9081.  1300 CONTINUE
  9082. C
  9083. C  PRINT HEADER.
  9084. C
  9085.       NREL = NREL + 1
  9086.       IRPW = K4NONE
  9087.       IMPW = K4NONE
  9088.       IF(NE(RPW,NONE)) IRPW = K4YES
  9089.       IF(NE(MPW,NONE)) IMPW = K4YES
  9090. C
  9091.       WRITE(NOUTR,1320) NAME
  9092.  1320 FORMAT(20X,11HRELATION : ,A8)
  9093.       WRITE(NOUTR,1340) RDATE,IRPW
  9094.  1340 FORMAT(5X,11HLAST MOD : ,A10,9X,16HREAD PASSWORD : ,A4)
  9095.       WRITE(NOUTR,1360) DBNAME,IMPW
  9096.  1360 FORMAT(5X,9HSCHEMA : ,A10,10X,19H MODIFY PASSWORD : ,A4,/)
  9097. C
  9098.       WRITE(NOUTR,1380)
  9099.  1380 FORMAT(7X,4HNAME,10X,4HTYPE,10X,6HLENGTH,10X,3HKEY,/)
  9100. C
  9101. C  FIND AND PRINT ATTRIBUTE DESCRIPTIONS
  9102. C
  9103.       I = LOCATT(BLANK,NAME)
  9104.       IF(I.EQ.0) GO TO 1500
  9105.       WRITE(NOUT,1400) NAME
  9106.  1400 FORMAT(20H -WARNING- RELATION ,A8,
  9107.      X       26H HAS NO ATTRIBUTES DEFINED )
  9108.       GO TO 9999
  9109.  1500 CONTINUE
  9110.       CALL ATTGET(STATUS)
  9111.       IF(STATUS.NE.0) GO TO 1600
  9112.       CALL FILCH(KEY,1,CHPWD,BLANK)
  9113.       IF(ATTKEY.NE.0) KEY = K4YES
  9114. C
  9115. C  RETRIEVE LENGTH OF ATTRIBUTE.
  9116. C
  9117.       NCHAR = ATTCHA
  9118.       NWORDS = ATTWDS
  9119.       IF(ATTYPE.EQ.KZDOUB) NWORDS = NWORDS / 2
  9120.       IF(ATTYPE.EQ.KZDVEC) NWORDS = NWORDS / 2
  9121.       IF(ATTYPE.EQ.KZDMAT) NWORDS = NWORDS / 2
  9122.       IF(ATTYPE.NE.KZTEXT) GO TO 1510
  9123.       IF(NCHAR.NE.0) WRITE(NOUTR,1501) ATTNAM,ATTYPE,NCHAR,KEY
  9124.  1501 FORMAT(7X,A8,6X,A4,6X,I5,11H CHARACTERS,4X,A3)
  9125.       IF(NCHAR.EQ.0) WRITE(NOUTR,1502) ATTNAM,ATTYPE,KEY
  9126.  1502 FORMAT(7X,A8,6X,A4,10X,8HVARIABLE,8X,A3)
  9127.       GO TO 1500
  9128.  1510 CONTINUE
  9129.       IF(ATTYPE.EQ.KZIMAT) GO TO 1520
  9130.       IF(ATTYPE.EQ.KZRMAT) GO TO 1520
  9131.       IF(ATTYPE.EQ.KZDMAT) GO TO 1520
  9132.       IF(NWORDS.EQ.0) WRITE(NOUTR,1502) ATTNAM,ATTYPE,KEY
  9133.       IF(NWORDS.NE.0) WRITE(NOUTR,1503) ATTNAM,ATTYPE,NWORDS,KEY
  9134.  1503 FORMAT(7X,A8,6X,A4,10X,I4,12X,A3)
  9135.       GO TO 1500
  9136.  1520 CONTINUE
  9137.       IF(NWORDS.EQ.0) GO TO 1530
  9138.       NC = NWORDS / NCHAR
  9139.       WRITE(NOUTR,1504) ATTNAM,ATTYPE,NCHAR,NC,KEY
  9140.  1504 FORMAT(7X,A8,6X,A4,8X,I4,4H BY ,I4,6X,A3)
  9141.       GO TO 1500
  9142.  1530 CONTINUE
  9143.       IF(NCHAR.EQ.0) GO TO 1540
  9144.       WRITE(NOUTR,1505) ATTNAM,ATTYPE,NCHAR,KEY
  9145.  1505 FORMAT(7X,A8,6X,A4,8X,I4,12H BY VARIABLE,2X,A3)
  9146.       GO TO 1500
  9147.  1540 CONTINUE
  9148.       WRITE(NOUTR,1506) ATTNAM,ATTYPE,KEY
  9149.  1506 FORMAT(7X,A8,6X,A4,4X,20HVARIABLE BY VARIABLE,2X,A3)
  9150.       GO TO 1500
  9151. C
  9152.  1600 CONTINUE
  9153. C
  9154. C
  9155.       WRITE(NOUTR,1620) NTUPLE
  9156.  1620 FORMAT(/,10X,25HCURRENT NUMBER OF ROWS = ,I8,/)
  9157.       IF(EQKEYW(2,KWALL,3)) GO TO 1100
  9158.       GO TO 9999
  9159.  8000 CONTINUE
  9160. C
  9161. C     NO RELATIONS DEFINED - ALL SPECIFICATION
  9162. C
  9163.       WRITE (NOUT,20)
  9164.       GO TO 9999
  9165.  8100 CONTINUE
  9166. C
  9167. C     NO RELATIONS PERMITTED - ALL SPECIFICATION
  9168. C
  9169.       WRITE (NOUT,1260)
  9170.       GO TO 9999
  9171.  8200 CONTINUE
  9172.       WRITE(NOUT,8210)
  9173.  8210 FORMAT(35H -ERROR- TOO MANY ITEMS FOR LISTREL )
  9174.       GO TO 9999
  9175. C
  9176. C  ALL DONE.
  9177. C
  9178.  9999 RETURN
  9179.       END
  9180.       INTEGER FUNCTION LSTRNG(STR1,IC1,LC1,STR2,IC2,LC2)
  9181.         Include TEXT.BLK
  9182. C
  9183. C  PURPOSE:   LOCATE ONE STRING OF CHARACTERS IN ANOTHER
  9184. C
  9185. C  PARAMETERS:
  9186. C     STR1----FIRST HOLLERITH STRING
  9187. C     IC1-----STARTING CHARACTER IN STR1 TO START THE SCAN
  9188. C     LC1-----LENGTH OF STR1
  9189. C     STR2----SECOND HOLLERITH STRING
  9190.  
  9191. C     IC2-----STARTING CHARACTER IN STR2
  9192. C     LC2-----LENGTH OF STR2
  9193. C     LSTRNG--CHARACTER POSITION IN STR1 WHERE STR2 WAS FOUND
  9194. C             0 IF IT CANNOT FIND IT
  9195. C
  9196.       CHARACTER*1 STR1(1)
  9197.       CHARACTER*1 STR2(1)
  9198. C
  9199. C  CHECK THAT THE PARAMETERS ARE GOOD.
  9200. C
  9201.       L2 = LC2 - 1
  9202.       IF(LC2.GT.LC1) GO TO 9000
  9203.       I1 = IC1 - 1
  9204.       DO 300 I=1,LC1
  9205.       I1 = I1 + 1
  9206.       IF(STR1(I1).NE.STR2(IC2)) GO TO 300
  9207. C
  9208. C  MATCHING FIRST CHARACTERS. SCAN THE REST.
  9209. C
  9210.       IF(L2.EQ.0) GO TO 200
  9211.       DO 100 J=1,L2
  9212.       IF(STR1(I1+J).NE.STR2(IC2+J)) GO TO 300
  9213.   100 CONTINUE
  9214. C
  9215. C  WE FOUND A MATCH.
  9216. C
  9217.   200 CONTINUE
  9218.       LSTRNG = I1
  9219.       RETURN
  9220. C
  9221. C  KEEP LOOKING.
  9222. C
  9223.   300 CONTINUE
  9224. C
  9225. C  NOT THERE.
  9226. C
  9227.  9000 CONTINUE
  9228.       LSTRNG = 0
  9229.       RETURN
  9230.       END
  9231.       SUBROUTINE LXCONS
  9232.         Include TEXT.BLK
  9233. C
  9234. C  PURPOSE: THIS ROUTINE INITIALIZES THE HOLLERITH CONSTANTS USED
  9235. C           BY THE LXLREC ROUTINES. THE CODE IS MACHINE DEPENDENT.
  9236. C
  9237.         Include LXGEN.BLK
  9238.         Include LXCON.BLK
  9239.         Include LXCARD.BLK
  9240.         Include LXWRDS.BLK
  9241. C
  9242. C  VARIABLES USED BY THE LXCON AND LXCARD COMMON BLOCKS
  9243. C
  9244.     CHARACTER*4 CLTEXT,CLREAL
  9245.     EQUIVALENCE(CLTEXT,JLTEXT)
  9246.     CHARACTER*4 CLINT,CLREPT,CLGENR,CLNULL
  9247.     EQUIVALENCE(CLINT,JLINT),(CLREPT,JLREPT)
  9248.     EQUIVALENCE(CLGENR,JLGENR),(CLNULL,JLNULL)
  9249.     CHARACTER*4 CLSAME,CLASAM
  9250.     EQUIVALENCE(CLSAME,JLSAME),(CLASAM,JLASAM)
  9251.     CHARACTER*4 CYON,CYOFF,CYEOF,CYECHO,CYPROM,CYINPT,CYOTPT
  9252.     CHARACTER*4 CYDOLL,CYSEMI,CYCOMM,CYBLAN,CYPLUS
  9253.     CHARACTER*4 CYQUOT,CYPRES,CYBLNK
  9254.     EQUIVALENCE (CYON,JYON),(CYOFF,JYOFF),(CYECHO,JYECHO)
  9255.     EQUIVALENCE (CYPROM,JYPROM),(CYINPT,JYINPT)
  9256.     EQUIVALENCE (CYOTPT,JYOTPT),(CYDOLL,JYDOLL)
  9257.     EQUIVALENCE (CYSEMI,JYSEMI),(CYCOMM,JYCOMM)
  9258.     EQUIVALENCE (CYBLAN,JYBLAN),(CYPLUS,JYPLUS)
  9259.     EQUIVALENCE (CYQUOT,JYQUOT),(CYPRES,JYPRES)
  9260.     EQUIVALENCE (CYBLNK,JYBLNK)
  9261.       DATA CLTEXT /'TEXT'/
  9262.       DATA CLREAL  /'REAL'/
  9263.       DATA CLINT /'INT'/
  9264.       DATA CLSAME /'*N'/
  9265.       DATA CLASAM /'**'/
  9266.       DATA CLREPT /'*=N'/
  9267.       DATA CLGENR /'*+N'/
  9268.       DATA CLNULL /'-0-'/
  9269. C
  9270. C  VARIABLES USED BY THE LXWRDS COMMON BLOCK
  9271. C
  9272.       DATA CYON /'ON'/
  9273.       DATA CYOFF /'OFF'/
  9274.       DATA CYEOF /'EOF'/
  9275.       DATA CYECHO /'ECHO'/
  9276.       DATA CYPROM /'PROM'/
  9277.       DATA CYINPT /'INPT'/
  9278.       DATA CYOTPT /'OTPT'/
  9279.       DATA CYDOLL /'DOLL'/
  9280.       DATA CYSEMI /'SEMI'/
  9281.       DATA CYCOMM /'COMM'/
  9282.       DATA CYBLAN /'BLAN'/
  9283.       DATA CYPLUS /'PLUS'/
  9284.       DATA CYQUOT /'QUOT'/
  9285.       DATA CYPRES /'PRES'/
  9286.       DATA CYBLNK /' '/
  9287. C
  9288. C  SET THE LXGEN VARIABLES
  9289. C
  9290.       NUMREP= 0
  9291. C
  9292. C  MACHINE DEPENDENT VARIABLES USED BY THE LXCON COMMON BLOCK
  9293. C
  9294.       NWORD = 290
  9295.       MCHAR = 1160
  9296.       NCPW = 4
  9297. C
  9298. C  SET THE LXCON AND LXCARD VARIABLES
  9299. C
  9300.       MITEM = 100
  9301.       NIN = 9
  9302.       NOUT = 9
  9303.       NEXT = 1
  9304.       NEWN = 0
  9305.       OLDN = 0
  9306.       ECHO = .TRUE.
  9307. C **** %%%%
  9308.     DO 1000 NN=1,10
  9309. c **************%%%%%%%%%%%%%%&&&&&&&&&&&&&&&&
  9310. c **  Nonstandard ... relies on how Fortran converts
  9311. c **  chars to integers
  9312. c
  9313. 1000    DIGITS(NN)=CHAR(47+NN)
  9314. C INIT DIGITS TO ASCII
  9315. C NOTE WE SET THESE UP AS CHARACTERS SO
  9316. C ANY COMPILER HIGHC ANY COMPILER SECOND-BYTE PECULIARITIES WILL BE
  9317. C DUPLICATED HERE AS WELL AS IN DATA READ IN ETC.
  9318.       MINUS = CHAR( 45)
  9319.       PLUS = CHAR( 43)
  9320.       CONT = CHAR( 43)
  9321.       POINT = CHAR( 46)
  9322.       DOLLAR = CHAR( 36)
  9323.       SEMI = CHAR( 59)
  9324.       STAR = CHAR( 42)
  9325.       LPAREN = CHAR( 40)
  9326.       RPAREN = CHAR( 41)
  9327.       QUOTES = CHAR( 34)
  9328.       BLANK = CHAR( 32)
  9329.       BLANKS = CHAR( 32)
  9330.       TEXT = JLTEXT
  9331.       REAL = CLREAL
  9332.       INTGER = JLINT
  9333.       SAME = JLSAME
  9334.       ALLSAM =JLASAM
  9335.       REPEAT = JLREPT
  9336.       GENRAT = JLGENR
  9337.       EQUALS = CHAR( 61)
  9338.       COMMA = CHAR( 44)
  9339.       E = CHAR( 69)
  9340.       NULL = JLNULL
  9341.       SLASH = CHAR( 47)
  9342. C
  9343. C  SET THE LXWRDS VARIABLES
  9344. C
  9345.       KYA    = CHAR( 65)
  9346.       KYB    = CHAR( 66)
  9347.       KYC    = CHAR( 67)
  9348.       KYD    = CHAR( 68)
  9349.       KYE    = CHAR( 69)
  9350.       KYF    = CHAR( 70)
  9351.       KYH    = CHAR( 72)
  9352.       KYI    = CHAR( 73)
  9353.       KYK    = CHAR( 75)
  9354.       KYL    = CHAR( 76)
  9355.       KYM    = CHAR( 77)
  9356.       KYN    = CHAR( 78)
  9357.       KYO    = CHAR( 79)
  9358.       KYP    = CHAR( 80)
  9359.       KYQ    = CHAR( 81)
  9360.       KYR    = CHAR( 82)
  9361.       KYS    = CHAR( 83)
  9362.       KYT    = CHAR( 84)
  9363.       KYU    = CHAR( 85)
  9364.       KYON   = JYON
  9365.       KYOFF  = JYOFF
  9366.       KYEOF  = JYEOF
  9367.       KYECHO = JYECHO
  9368.       KYPROM = JYPROM
  9369.       KYINPT = JYINPT
  9370.       KYOTPT = JYOTPT
  9371.       KYDOLL = JYDOLL
  9372.       KYSEMI = JYSEMI
  9373.       KYCOMM = JYCOMM
  9374.       KYBLAN = JYBLAN
  9375.       KYPLUS = JYPLUS
  9376.       KYQUOT = JYQUOT
  9377.       KYPRES = JYPRES
  9378.       KYBLNK = JYBLNK
  9379.       RETURN
  9380.       END
  9381.       FUNCTION LXCREC(I,J)
  9382.         Include TEXT.BLK
  9383. C
  9384. C     THIS FUNCTION RETURNS THE JTH CHARACTER OF THE ITH ITEM
  9385. C     LEFT ADJUST BLANK FILL IF POSSIBLE AND ALL BLANKS OTHERWISE.
  9386. C
  9387.         Include LXCARD.BLK
  9388.         Include LXCON.BLK
  9389.       LXCREC = BLANKS
  9390.       IF(I.LT.1) RETURN
  9391.       IF(I.GT.NEWN) RETURN
  9392.       IF(J.LT.1) RETURN
  9393.       IF(TYPE(I).NE.TEXT) RETURN
  9394.       LEN = INT(RVAL(I))
  9395.       IF(J.GT.LEN) RETURN
  9396.       K = INTVAL(I)
  9397.       CALL GETT(NEWREC(K),J,LXCREC)
  9398.       RETURN
  9399.       END
  9400.       SUBROUTINE LXEND(LINE,LEN,LOC,MORE,NEWLEN)
  9401.         Include TEXT.BLK
  9402. C
  9403. C     THIS ROUTINE LOOKS FOR DOLLAR,SEMI OR PLUS AS A NEW
  9404. C     END OF LINE.  NOTE - DOLLAR, SEMI OR PLUS ARE NOT NOTED
  9405. C     IF IN A QUOTED TEXT OR A COMMENT UNLESS NO END OF QUOTE
  9406. C     OR COMMENT IS ENCOUNTERED.
  9407. C
  9408. C     INPUT  - LINE.....ONE CHARACTER PER WORD
  9409. C              LEN......LENGTH OF LINE
  9410. C     OUTPUT - LOC......LOCATION OF DOLLAR OR SEMI ELSE 0.
  9411. C              MORE......TRUE. IFF PLUS IS END
  9412. C              NEWLEN....CHARACTER BEFORE DOLLAR, SEMI OR PLUS ELSE LEN
  9413. C
  9414.         Include LXCON.BLK
  9415.       DIMENSION LINE(1)
  9416.       LOGICAL MORE
  9417. C
  9418. C     AN IF LOOP ON NUMBER OF CHARACTERS
  9419. C
  9420.       IC = 0
  9421.       IF(LEN.LE.0) GO TO 300
  9422.    10 CONTINUE
  9423.       IC = IC + 1
  9424.       IF(LINE(IC).EQ.DOLLAR) GO TO 100
  9425.       IF(LINE(IC).EQ.SEMI) GO TO 100
  9426.       IF(LINE(IC).EQ.QUOTES) GO TO 20
  9427.       IF(LINE(IC).EQ.STAR) GO TO 50
  9428.       IF(IC.GE.LEN) GO TO 300
  9429.       GO TO 10
  9430.    20 CONTINUE
  9431. C
  9432. C     POSSIBLE QUOTE - IGNORE IF SO
  9433. C
  9434.       IF(IC.EQ.LEN) GO TO 300
  9435.       IF(IC.EQ.1) GO TO 25
  9436.       IF(LINE(IC-1).EQ.BLANK) GO TO 25
  9437.       IF(LINE(IC-1).NE.COMMA) GO TO 10
  9438.    25 CONTINUE
  9439.       ICQ = IC
  9440.    30 CONTINUE
  9441.       ICQ = ICQ + 1
  9442.       IF(ICQ.GE.LEN) GO TO 10
  9443.       IF(LINE(ICQ).NE.QUOTES) GO TO 30
  9444.       IF(ICQ.EQ.LEN) GO TO 300
  9445.       IF(LINE(ICQ+1).NE.QUOTES)IC = ICQ +1
  9446.       IF(LINE(ICQ+1).NE.QUOTES) GO TO 10
  9447.       ICQ = ICQ + 1
  9448.       GO TO 30
  9449.    50 CONTINUE
  9450. C
  9451. C     STAR - POSSIBLE COMMENT
  9452. C
  9453.       IF(IC.EQ.LEN) GO TO 300
  9454.       ENDCOM = NULL
  9455.       IF(LINE(IC+1).EQ.LPAREN) ENDCOM = RPAREN
  9456.       IF(LINE(IC+1).EQ.SLASH) ENDCOM = SLASH
  9457.       IF(ENDCOM.EQ.NULL) GO TO 10
  9458. C
  9459. C     LOOK FOR END OF COMMENT
  9460. C
  9461.       ISTART = IC + 2
  9462.       IF(ISTART.GT.LEN) GO TO 300
  9463.       DO 60 I=ISTART,LEN
  9464.       IF(LINE(1).NE.ENDCOM) GO TO 60
  9465.       IC = I
  9466.       GO TO 10
  9467.    60 CONTINUE
  9468.       IC = IC + 1
  9469.       GO TO 10
  9470.   100 CONTINUE
  9471. C
  9472. C     FOUND A DOLLAR - USED TO BE WORTH SOMETHING
  9473. C
  9474.       LOC = IC
  9475.       MORE = .FALSE.
  9476.       NEWLEN = IC - 1
  9477.       GO TO 1000
  9478.   300 CONTINUE
  9479. C
  9480. C     MADE IT TO THE END
  9481. C
  9482.       NEWLEN = LEN
  9483.       LOC = 0
  9484.       MORE = .FALSE.
  9485.       IF(LEN.LE.0) GO TO 1000
  9486.       IF(LINE(NEWLEN).NE.CONT) GO TO 1000
  9487.       NEWLEN = NEWLEN - 1
  9488.       MORE = .TRUE.
  9489.  1000 CONTINUE
  9490.       RETURN
  9491.       END
  9492.       SUBROUTINE LXGENR
  9493.         Include TEXT.BLK
  9494. C
  9495. C     THIS SUBROUTINE INCREMENTS REAL AND INTEGER VALUES BY THE
  9496. C     INCREMENTS STORED IN LXGEN FOR GENERATION RECORDS.
  9497. C
  9498.         Include LXCARD.BLK
  9499.         Include LXGEN.BLK
  9500.         Include LXCON.BLK
  9501.       DO 10 I=1,NEWN
  9502.       IF(TYPE(I).EQ.INTGER) INTVAL(I) = INTVAL(I) + INTINC(I)
  9503.       IF(TYPE(I).EQ.REAL) RVAL(I) = RVAL(I) + RINC(I)
  9504.    10 CONTINUE
  9505.       NUMREP = NUMREP - 1
  9506.       RETURN
  9507.       END
  9508.       SUBROUTINE LXGENS(RECORD,LENREC,NUML,LINE,LEN,NEWLEN,
  9509.      X                  MORE,LOC,IERR)
  9510.         Include TEXT.BLK
  9511. C
  9512. C     THIS ROUTINE CRACKS A GENERATION RECORD INTO INTINC,RINC AND NUMRE
  9513. C
  9514. C     I/O      - RECORD....STRING FROM CALLING PROGRAM
  9515. C                LENREC....LENGTH OF RECORD
  9516. C                NUML......NUMBER OF READS THIS RECORD
  9517. C                LINE......HOLDER FOR USER INPUT
  9518. C                LEN.......NUMBER OF CHARACTERS IN LINE
  9519. C                NEWLEN....NUMBER CHARACTERS IN LINE THIS RECORD
  9520. C                MORE.......TRUE. IFF THIS IS PLUS RECORD
  9521. C                LOC.......LOCATION OF EOR
  9522. C     OUTPUT   - IERR......ERROR RETURN IF ANY
  9523. C
  9524.         Include LXCARD.BLK
  9525.         Include LXCON.BLK
  9526.         Include LXGEN.BLK
  9527.         Include LXCIT.BLK
  9528.       DIMENSION LINE(LEN)
  9529.       INTEGER RECORD(1)
  9530.       LOGICAL MORE
  9531.       INTEGER START
  9532.       IERR = 0
  9533.       NUMGEN = 0
  9534.       NUMREP = IVALUE
  9535. C
  9536. C     BIG LOOP ON ITEMS
  9537. C
  9538.    10 CONTINUE
  9539.       START = LAST + 1
  9540.       CALL LXNEXI(LINE,START,NEWLEN)
  9541.       IF(FIRST.NE.0) GO TO 100
  9542. C
  9543. C     OUT OF ITEMS
  9544. C
  9545.       IF((.NOT.MORE) .AND. (NUMGEN.EQ.OLDN)) GO TO 1000
  9546.       IF((.NOT.MORE).AND.(NUMGEN.GT.OLDN)) GO TO 8010
  9547. C
  9548. C     IF NO MORE - DEFAULT LAST ITEM TO **
  9549. C
  9550.       IF(.NOT.MORE)TYP = ALLSAM
  9551.       IF(.NOT.MORE) GO TO 200
  9552. C
  9553. C     GET ANOTHER LINE
  9554. C
  9555.       CALL LXLINE(RECORD,LENREC,NUML,LINE,LEN,LOC)
  9556.       IF(LXEOF) GO TO 1000
  9557.       CALL LXEND(LINE,LEN,LOC,MORE,NEWLEN)
  9558.       LAST = 0
  9559.       GO TO 10
  9560.   100 CONTINUE
  9561. C
  9562. C     PARSE THE ITEM
  9563. C
  9564.       IF(TYP.EQ.COMMA) GO TO 10
  9565.       IF(TYP.NE.INTGER) GO TO 150
  9566. C
  9567. C     INTEGER
  9568. C
  9569.       NUMGEN = NUMGEN + 1
  9570.       IF(NUMGEN.GT.OLDN) GO TO 8010
  9571.       IF(TYPE(NUMGEN).EQ.INTGER) GO TO 110
  9572.       IF(TYPE(NUMGEN).EQ.REAL) GO TO 8020
  9573.       IF(IVALUE.NE.0) GO TO 8020
  9574.   110 CONTINUE
  9575.       RINC(NUMGEN) = 0.
  9576.       INTINC(NUMGEN) = IVALUE
  9577.       GO TO 10
  9578.   150 CONTINUE
  9579.       IF(TYP.NE.REAL) GO TO 200
  9580. C
  9581. C     REAL
  9582. C
  9583.       NUMGEN = NUMGEN + 1
  9584.       IF(NUMGEN.GT.OLDN) GO TO 8010
  9585.       IF(TYPE(NUMGEN).NE.REAL) GO TO 8020
  9586.       INTINC(NUMGEN) = 0
  9587.       RINC(NUMGEN) = RVALUE
  9588.       GO TO 10
  9589.   200 CONTINUE
  9590.       IF((TYP.NE.SAME) .AND. (TYP.NE.ALLSAM)) GO TO 250
  9591. C
  9592. C     *N OR **
  9593. C
  9594.       NUMI = IVALUE
  9595.       IF(TYP.EQ.ALLSAM) NUMI = OLDN - NUMGEN
  9596.       IF((NUMGEN+NUMI).GT.OLDN) GO TO 8010
  9597.       DO 220 I=1,NUMI
  9598.       NUMGEN = NUMGEN + 1
  9599.       RINC(NUMGEN) = 0.
  9600.       INTINC(NUMGEN) = 0
  9601.   220 CONTINUE
  9602.       IF(FIRST.EQ.0) GO TO 1000
  9603.       GO TO 10
  9604.   250 CONTINUE
  9605.       IF(TYP.NE.REPEAT) GO TO 8050
  9606. C
  9607. C     *=N+STEP
  9608. C
  9609.       NUMI = IVALUE
  9610.       IF(NUMI.LE.0) GO TO 8030
  9611.       IF(NUMGEN.LE.0) GO TO 8040
  9612.       IF((NUMI+NUMGEN).GT.OLDN) GO TO 8010
  9613.       ICHECK = NULL
  9614.       IF(RINC(NUMGEN).NE.0.) ICHECK = REAL
  9615.       IF(INTINC(NUMGEN).NE.0) ICHECK = INTGER
  9616.       IF((ICHECK.NE.NULL).AND.(ICHECK.NE.TGEN)) GO TO 8020
  9617.       IF(TGEN.EQ.NULL) IGEN = 0
  9618.       IF(TGEN.EQ.NULL) RGEN = 0.
  9619.       IF(TGEN.EQ.REAL) ICHECK = REAL
  9620.       IF(IGEN.NE.0) ICHECK = INTGER
  9621.       RR = RINC(NUMGEN)
  9622.       II = INTINC(NUMGEN)
  9623.       DO 270 I=1,NUMI
  9624.       NUMGEN = NUMGEN + 1
  9625.       IF(ICHECK.EQ.NULL) GO TO 260
  9626.       IF(ICHECK.NE.TYPE(NUMGEN)) GO TO 8020
  9627.   260 CONTINUE
  9628.       II = II + IGEN
  9629.       RR = RR + RGEN
  9630.       RINC(NUMGEN) = RR
  9631.       INTINC(NUMGEN) = II
  9632.   270 CONTINUE
  9633.       GO TO 10
  9634.  1000 CONTINUE
  9635.       RETURN
  9636. C
  9637. C     ERROR MESSAGES
  9638. C
  9639.  8010 CONTINUE
  9640. C
  9641. C     TOO MANY ITEMS IN GENERATION RECORD
  9642. C
  9643.       IERR = 21
  9644.       IF(LENREC.NE.0) GO TO 1000
  9645.       IF(NOUT.EQ.0) GO TO 1000
  9646.       WRITE (NOUT,8015)
  9647.  8015 FORMAT(17H *** ERROR *** - ,
  9648.      X       36HNUMBER OF ITEMS IN GENERATION RECORD,
  9649.      X /,17X,27HMUST MATCH PREVIOUS RECORD  )
  9650.       GO TO 1000
  9651.  8020 CONTINUE
  9652. C
  9653. C     TYPE DIFFERENCE
  9654. C
  9655.       IERR = 22
  9656.       IF(LENREC.NE.0) GO TO 1000
  9657.       IF(NOUT.EQ.0) GO TO 1000
  9658.       WRITE(NOUT,8025)
  9659.  8025 FORMAT(17H *** ERROR *** - ,
  9660.      X       34HTYPE MISMATCH ON GENERATION RECORD)
  9661.       GO TO 1000
  9662.  8030 CONTINUE
  9663. C
  9664. C     *=N WITH N .LE. 0
  9665. C
  9666.       IERR = 6
  9667.       GO TO 1000
  9668.  8040 CONTINUE
  9669. C
  9670. C     *=N FIRST ITEM
  9671. C
  9672.       IERR = 4
  9673.       GO TO 1000
  9674.  8050 CONTINUE
  9675. C
  9676. C     ILLEGAL TYPE ON GENERATION RECORDS
  9677. C
  9678.       IERR = 25
  9679.       IF(LENREC.NE.0) GO TO 1000
  9680.       IF(NOUT.EQ.0) GO TO 1000
  9681.       WRITE (NOUT,8055)
  9682.  8055 FORMAT(17H *** ERROR *** - ,
  9683.      X       45HILLEGAL TEXT OR *+N ITEM IN GENERATION RECORD )
  9684.       GO TO 1000
  9685.       END
  9686.       SUBROUTINE LXGETI(STRING,LEN,IFINT,VALUE)
  9687.         Include TEXT.BLK
  9688. C
  9689. C     PURPOSE - INTERPRET A STRING OF CHARACTERS AS AN INTEGER.
  9690. C
  9691. C     INPUT  - STRING....ARRAY OF CHARACTERS ONE PER WORD
  9692. C              LEN.......NUMBER OF CHARACTERS IN STRING
  9693. C     OUTPUT - IFINT..... .TRUE. IFF STRING REPRESENTS AN INTEGER
  9694. C              VALUE.....THE ACTUAL VALUE OF THE INTEGER IN STRING.
  9695. C
  9696.         Include LXCON.BLK
  9697.       INTEGER VALUE
  9698.       INTEGER STRING(LEN)
  9699.       LOGICAL IFINT
  9700.       NEW = 0
  9701.       VALUE = 0
  9702.       IFINT = .FALSE.
  9703.       IS = 1
  9704.       ISIGN = 1
  9705.       IF(STRING(1).NE.MINUS) GO TO 5
  9706.       ISIGN = -1
  9707.       IS = 2
  9708.     5 CONTINUE
  9709.       IF(STRING(1).NE.PLUS) GO TO 10
  9710.       IS = 2
  9711.    10 CONTINUE
  9712.       IF(IS.GT.LEN) GO TO 1000
  9713. C
  9714. C     LOOK AT EACH CHARACTER - IF INTEGER ADD IT IN
  9715. C
  9716.       DO 100 I=IS,LEN
  9717.       DO 20 J=1,10
  9718.       IF(STRING(I).EQ.DIGITS(J)) GO TO 30
  9719.    20 CONTINUE
  9720. C
  9721. C     NOT INTEGER
  9722. C
  9723.       GO TO 1000
  9724.    30 CONTINUE
  9725.       NEW = 10 * NEW + J - 1
  9726.   100 CONTINUE
  9727.       VALUE = ISIGN*NEW
  9728.       IFINT = .TRUE.
  9729.  1000 CONTINUE
  9730.       RETURN
  9731.       END
  9732.       SUBROUTINE LXGETR(STRING,LEN,IFREAL,VALUE)
  9733.         Include TEXT.BLK
  9734. C
  9735. C     PURPOSE - PARSE A REAL NUMBER - DEFINED AS  ?I1.I2E?I3 WHERE
  9736. C               ? STANDS FOR EITHER + OR - AND I1,I2,I3 ARE INTEGERS.
  9737. C               EITHER THE POINT OR THE "E" MUST BE PRESENT AND THERE
  9738. C               MUST BE AT LEAST TWO CHARACTERS.
  9739. C               IN ADDITION THERE MUST BE AT LEAST ONE DIGIT.
  9740. C
  9741. C     INPUT  - STRING...REAL NUMBER ONE CHARACTER PER WORD.
  9742. C              LEN......LENGTH OF STRING
  9743. C     OUTPUT - IFREAL...TRUE IFF STRING REPRESENTS A REAL NUMBER
  9744. C              VALUE....THE REAL REAL NUMBER
  9745. C
  9746. C     METHOD - I1,I2 AND I3 ARE IDENTIFIED AS SUBSTRINGS AND LXGETI
  9747. C              TURNS THEM INTO INTEGERS WHICH ARE FLOATED AND TURNED
  9748. C              INTO THE REAL REAL VALUE.
  9749. C
  9750.         Include LXCON.BLK
  9751.       INTEGER STRING(LEN)
  9752.       INTEGER START(3),LENI(3),IN(3)
  9753.       REAL R(3)
  9754.       LOGICAL IFREAL,IFINT,DOT,EXP
  9755.       VALUE = 0.
  9756.       IFREAL = .FALSE.
  9757.       SIGN1 = 1.
  9758.       SIGN2 = 1.
  9759.       DO 5 I=1,3
  9760.       LENI(I) = 0
  9761.       START(I) = 0
  9762.       IN(I) = 0
  9763.       R(I) = 0.
  9764.     5 CONTINUE
  9765.       DOT = .FALSE.
  9766.       EXP = .TRUE.
  9767. C
  9768. C     FIND START AND LENGTHS OF THE THREE INTEGERS (MAY BE EMPTY)
  9769. C
  9770.       IF(LEN.LT.2) GO TO 1000
  9771.       START(1) = 1
  9772.       IF(STRING(1).EQ.PLUS) START(1) = 2
  9773.       IF(STRING(1).EQ.MINUS) START(1) = 2
  9774.       IF(STRING(1).EQ.MINUS) SIGN1 = -1.
  9775. C
  9776. C     LOOK FOR POINT
  9777. C
  9778.       IS = START(1)
  9779.       DO 10 I=IS,LEN
  9780.       IF(STRING(I).EQ.POINT) GO TO 20
  9781.       IF(STRING(I).EQ.E) GO TO 15
  9782.    10 CONTINUE
  9783.    15 CONTINUE
  9784.       LENI(1) = 0
  9785.       START(2) = START(1)
  9786.       GO TO 30
  9787.    20 CONTINUE
  9788.       DOT = .TRUE.
  9789.       LENI(1) = I - START(1)
  9790.       START(2) = I + 1
  9791.    30 CONTINUE
  9792.       IS = START(2)
  9793.       IF(IS.GT.LEN) GO TO 200
  9794. C
  9795. C     LOOK FOR E
  9796. C
  9797.       DO 40 I=IS,LEN
  9798.       IF(STRING(I).EQ.E) GO TO 50
  9799.       IF(DOT.AND.(STRING(I).EQ.PLUS)) GO TO 50
  9800.       IF(DOT.AND.(STRING(I).EQ.MINUS)) GO TO 50
  9801.    40 CONTINUE
  9802.       I = LEN + 1
  9803.       EXP = .FALSE.
  9804.    50 CONTINUE
  9805.       LENI(2) = I - START(2)
  9806.       START(3) = I + 1
  9807.       IF(START(3).GT.LEN) GO TO 200
  9808.       IS = START(3)
  9809.       IF(STRING(IS).EQ.MINUS) SIGN2 = -1.
  9810.       IF(STRING(IS).EQ.MINUS) START(3) = IS + 1
  9811.       IF(STRING(IS).EQ.PLUS) START(3) = IS + 1
  9812.       LENI(3) = LEN - START(3) + 1
  9813.   200 CONTINUE
  9814. C
  9815. C     IF NO EXPONENT OR DECIMAL POINT THEN NOT REAL
  9816. C
  9817.       IF( (.NOT. DOT) .AND. (.NOT. EXP) ) GO TO 1000
  9818. C
  9819. C     IF NO NUMBERS THEN NOT REAL
  9820. C
  9821.       NUM = LENI(1) + LENI(2) + LENI(3)
  9822.       IF(NUM.EQ.0) GO TO 1000
  9823. C
  9824. C  IF NO INTEGER PRECEEDING THE E - ITEM IS TEXT
  9825. C
  9826.       IF((LENI(1)+LENI(2)).EQ.0) GO TO 1000
  9827. C
  9828. C      SWITCH I1 AND I2 IF NO DECIMAL POINT FOUND
  9829. C
  9830.       IF(DOT) GO TO 210
  9831.       LENI(1) = LENI(2)
  9832.       START(1) = START(2)
  9833.       LENI(2) = 0
  9834.   210 CONTINUE
  9835. C
  9836. C     NOW MAKE I1,I2, AND I3 INTO INTEGERS
  9837. C
  9838.       DO 250 I=1,3
  9839.       IF(LENI(I) .EQ. 0) GO TO 250
  9840.       IS = START(I)
  9841.       CALL LXGETI(STRING(IS),LENI(I),IFINT,IN(I))
  9842.       IF(.NOT.IFINT) GO TO 1000
  9843.       R(I) = FLOAT(IN(I))
  9844.   250 CONTINUE
  9845. C
  9846. C     NOW MAKE THE REAL REAL NUMBER
  9847. C
  9848.       LEN2 = LENI(2)
  9849.       R(2) = R(2) / (10.**LEN2)
  9850.       R(1) = SIGN1 * ( R(1) + R(2) )
  9851.       IF( (LENI(1)+LENI(2)) .EQ. 0 ) R(1) = SIGN1
  9852.       I3 = IN(3)
  9853. C
  9854. C  CHECK THE THE EXPONENT IS LEGAL E-38 TO E+38
  9855. C
  9856.       LENX = LENI(1) - 1
  9857.       IF(LENX.LT.0) LENX = 0
  9858.       IF((LENX+I3).GT.38) GO TO 1000
  9859.       R(3) = 10.**I3
  9860.       IF(SIGN2.EQ.-1.) R(3) = 1./R(3)
  9861.       VALUE = R(1) * R(3)
  9862.       IFREAL = .TRUE.
  9863.  1000 CONTINUE
  9864.       RETURN
  9865.       END
  9866.       FUNCTION LXID(I)
  9867.         Include TEXT.BLK
  9868. C
  9869. C     THIS FUNCTION RETURNS THE ID OF THE ITH ITEM IN THE LAST
  9870. C      LXLREC RECORD.
  9871. C     ID'S MAY BE 4HTEXT,3HINT,4HREAL, OR 3HEOF
  9872. C
  9873.         Include LXCARD.BLK
  9874.         Include LXCON.BLK
  9875.       LXID = BLANKS
  9876.       IF((I.GT.0) .AND. (I.LE.NEWN)) LXID = TYPE(I)
  9877.       RETURN
  9878.       END
  9879.       FUNCTION LXIREC(I)
  9880.         Include TEXT.BLK
  9881. C
  9882. C     THIS FUNCTION RETURNS THE INTEGER VALUE OF THE ITH ITEM.
  9883. C     LXIREC IS RETURNED 0 IF I IS NOT VALID INTEGER ITEM.
  9884. C
  9885.         Include LXCARD.BLK
  9886.         Include LXCON.BLK
  9887.       LXIREC = 0
  9888.       IF(I.LT.1) RETURN
  9889.       IF(I.GT.NEWN) RETURN
  9890.       IF(TYPE(I).NE.INTGER) RETURN
  9891.       LXIREC = INTVAL(I)
  9892.       RETURN
  9893.       END
  9894.       FUNCTION LXITEM(NUM)
  9895.         Include TEXT.BLK
  9896. C
  9897. C     THIS FUNCTION RETURNS THE NUMBER OF ITEMS READ IN THE LAST
  9898. C      LXLREC RECORD.
  9899. C
  9900.         Include LXCARD.BLK
  9901.       NUM = NEWN
  9902.       LXITEM = NEWN
  9903.       RETURN
  9904.       END
  9905.       FUNCTION LXLENC(I)
  9906.         Include TEXT.BLK
  9907. C
  9908. C     THIS FUNCTION RETURNS THE LENGTH IN CHARACTERS OF THE ITH ITEM.
  9909. C     LXLENC IS RETURNED AS ZERO IF I IS NOT VALID TEXT ITEM.
  9910. C
  9911.         Include LXCARD.BLK
  9912.         Include LXCON.BLK
  9913.       LXLENC = 0
  9914.       IF(I.LT.1) RETURN
  9915.       IF(I.GT.NEWN) RETURN
  9916.       IF(TYPE(I).EQ.INTGER) RETURN
  9917.       IF(TYPE(I).EQ.REAL) RETURN
  9918.       LXLENC = INT(RVAL(I))
  9919.       RETURN
  9920.       END
  9921.       FUNCTION LXLENW(I)
  9922.         Include TEXT.BLK
  9923. C
  9924. C     THIS FUNCTION RETURNS THE LENGTH IN WORDS OF THE ITH ITEM.
  9925. C     IF I IS NOT A VALID TEXT ITEM LXLENW IS RETURNED ZERO.
  9926. C     WORDS HERE REFERS TO A FORTRAN INTEGER ITEM.
  9927. C     (E.G. 10 CHARACTERS ON CYBERS,8 CHARACTERS ON CRAY...)
  9928. C
  9929.         Include LXCARD.BLK
  9930.         Include LXCON.BLK
  9931.       LXLENW = 0
  9932.       IF(I.LT.1) RETURN
  9933.       IF(I.GT.NEWN) RETURN
  9934.       LXLENW = 1
  9935.       IF(TYPE(I).EQ.INTGER) RETURN
  9936.       IF(TYPE(I).EQ.REAL) RETURN
  9937.       LEN = INT(RVAL(I))
  9938.       LXLENW = ((LEN-1)/NCPW) + 1
  9939.       RETURN
  9940.       END
  9941.       SUBROUTINE LXLINE(RECORD,LENREC,NUML,LINE,LEN,LOC)
  9942.         Include TEXT.BLK
  9943. C
  9944. C     THIS ROUTINE GETS THE NEXT LINE FOR LXLREC TO PARSE.  IF LENREC
  9945. C     IS ZERO, FILE NIN IS READ, ELSE THE LINE IS EXTRACTED FROM RECORD.
  9946. C     IF LOC IS NOT ZERO NEW LINE IS ALREADY IN LINE, SIMPLY
  9947. C     MOVE THE DATA TO THE FRONT OF LINE.
  9948. C
  9949.         Include LXCARD.BLK
  9950.         Include PROM.BLK
  9951.         Include LXCON.BLK
  9952.     Integer LINE
  9953.         DIMENSION LINE(80)
  9954.     CHARACTER*1 LCLINE(80)
  9955.         INTEGER RECORD(1)
  9956.     INTEGER WKLN
  9957.     CHARACTER*1 WKLC(4)
  9958.     EQUIVALENCE(WKLN,WKLC(1))
  9959.     INTEGER*2 KGOT
  9960.       IF(LOC.NE.0) GO TO 200
  9961.       NUML = NUML + 1
  9962.       IF(LENREC.NE.0) GO TO 100
  9963. C
  9964. C     FROM FILE NIN
  9965. C
  9966.       LEN = 80
  9967. C
  9968. 1700    CONTINUE
  9969. c ***** System Dependent ***
  9970.       IF(NIN.EQ.9) WRITE(NOUT,5) PROM
  9971.     5 FORMAT(1X,A2,$)
  9972.       READ (NIN,10,END=13) LINE
  9973.    10 FORMAT(80A1)
  9974. C HANDLE SPAWN COMMAND IF POSSIBLE...
  9975.     IF(NIN.NE.9)GOTO 1705
  9976.     DO 1708 N=1,80
  9977. C GET COMMAND INTO BYTE ARRAY...
  9978.     WKLN=LINE(N)
  9979.     LCLINE(N)=WKLC(1)
  9980. 1708    CONTINUE
  9981.     CALL USRCMD(LCLINE,KGOT)
  9982.     IF(KGOT.EQ.1)GOTO 1700
  9983. C AFTER A SPAWN GO READ SOME MORE.
  9984. 1705    CONTINUE
  9985.         LXEOF = .FALSE.
  9986. C FORCE CHARS FROM TERMINALS TO BE UPPER CASE
  9987.     IF(NIN.NE.9)GOTO 14
  9988. C ONLY CHANGE CHARS FROM A TTY
  9989. C ALSO STOP CHANGING IF WE GET TO A " CHARACTER
  9990.     DO 11 N=1,80
  9991. c    NN=MOD(LINE(N),256)
  9992.     WKLN=LINE(N)
  9993.     NN=ICHAR(WKLC(1))
  9994.     IF(NN.EQ.34)GOTO 14
  9995. C 34 IS " CHARACTER IN ASCII
  9996. C REPLACE a-z BY A-Z AND LEAVE ALL ELSE ALONE.
  9997. C TRY TO LEAVE HIGH PARTS OF INTEGER ALONE.
  9998. C
  9999.     IF(NN.GE.97.AND.NN.LE.122)WKLC(1)=CHAR(NN-32)
  10000.     LINE(N)=WKLN
  10001. C    IF(NN.GE.97.AND.NN.LE.122)LINE(N)=(LINE(N)/256)*256+(NN-32)
  10002. 11    CONTINUE
  10003.       GO TO 14
  10004.    13 CONTINUE
  10005.       LXEOF = .TRUE.
  10006.    14 CONTINUE
  10007. C
  10008.       IF(LXEOF) GO TO 1000
  10009.       IF(NOUT.EQ.0) GO TO 1000
  10010.       IF(.NOT.ECHO) GO TO 1000
  10011.       WRITE(NOUT,20) LINE
  10012.    20 FORMAT(16H INPUT LINE ... ,80A1)
  10013.       GO TO 1000
  10014.   100 CONTINUE
  10015. C
  10016. C     GET LINE FROM RECORD
  10017. C
  10018.       LEN = 0
  10019.       I1 = 80*(NUML-1) + 1
  10020.       I2 = 80*NUML
  10021.       IF(I1.GT.LENREC) GO TO 1000
  10022.       IF(I2.GT.LENREC) I2 = LENREC
  10023.       DO 150 I=I1,I2
  10024.       LEN = LEN + 1
  10025.       CALL GETT(RECORD,I,LINE(LEN))
  10026.   150 CONTINUE
  10027.       GO TO 1000
  10028.   200 CONTINUE
  10029.       NEWLEN = LEN - LOC
  10030.       IF(NEWLEN.LE.0) GO TO 230
  10031.       DO 220 I=1,NEWLEN
  10032.       LOC = LOC + 1
  10033.       LINE(I) = LINE(LOC)
  10034.   220 CONTINUE
  10035.   230 CONTINUE
  10036.       LEN = NEWLEN
  10037.       LOC = 0
  10038.  1000 CONTINUE
  10039.       IF(LEN.LE.0) RETURN
  10040. C
  10041. C     IGNORE TRAILING BLANKS
  10042. C
  10043.       ICHECK = LEN + 1
  10044.       DO 1100 I=1,LEN
  10045.       ICHECK = ICHECK - 1
  10046.       IF(LINE(ICHECK).NE.BLANKS) GO TO 1200
  10047.  1100 CONTINUE
  10048.       ICHECK = 1
  10049.  1200 CONTINUE
  10050.       LEN = ICHECK
  10051.       RETURN
  10052.       END
  10053.       SUBROUTINE LXLREC(RECORD,LENREC,IERR)
  10054.         Include TEXT.BLK
  10055. C
  10056. C     LXLREC BREAKS INPUT STRINGS INTO TEXT,REAL OR INTEGER ITEMS.
  10057. C
  10058. C     INPUT  - RECORD....ONE RECORD IN A HOLLERITH STRING IN 80
  10059. C                        CHARACTER CHUNKS.  IF MORE THAN 80 CHARACTERS
  10060. C                        ARE NEEDED ALL BUT THE LAST CHUNK SHOULD END
  10061. C                        WITH A PLUS.  THE LAST CHUNK NEED NOT BE A FULL
  10062. C                        80 CHARACTERS.
  10063. C              LENREC....LENGTH OF RECORD IN CHARS.
  10064. C                        IF 0 READ INPUT FROM INPUT
  10065. C     OUTPUT - IERR......ERROR RETURN IF LENREC IS NOT ZERO.
  10066. C
  10067. C
  10068. C     LXLREC ERROR RETURNS
  10069. C
  10070. C     NUMBER         MEANING
  10071. C     ------    ---------------------------------------------------
  10072. C        1 ..... *N EXTENDS PAST PREVIOUS RECORD
  10073. C        2 ..... *N OR ** OPTION REQUESTS LESS THAN ONE ITEM
  10074.  
  10075. C        3 ..... TOO MANY ITEMS
  10076. C        4 ..... *=N WAS FIRST ITEM
  10077. C        5 ..... *+N WAS NOT FIRST ITEM
  10078. C        6 ..... *=N WHERE N WAS NOT POSITIVE
  10079. C        7 ..... TOO MANY TEXT CHARACTERS
  10080. C        8 ..... *=N+STEP DOES NOT AGREE IN TYPE WITH PREVIOUS ITEM
  10081. C       21 ..... NUMBER OF ITEMS IN GENERATION RECORD FAILS TO
  10082. C                MATCH PREVIOUS RECORD.
  10083. C       22 ..... TYPE MISMATCH ON GENERATION RECORD.
  10084. C       25 ..... ILLEGAL TEXT OR *+N ITEM ON GENERATION RECORD.
  10085. C
  10086.         Include LXCARD.BLK
  10087.         Include LXCON.BLK
  10088.         Include LXCIT.BLK
  10089.         Include LXGEN.BLK
  10090.         Include LXWRDS.BLK
  10091.       INTEGER RECORD(1),LINE(80),START
  10092.       LOGICAL MORE,TTY,IFSET
  10093.       DATA LOC /0/
  10094. C
  10095. C     BRANCH IF GENERATION
  10096. C
  10097.       IF(NUMREP.NE.0) GO TO 900
  10098.     5 CONTINUE
  10099. C
  10100. C     MOVE CURRENT TO OLD
  10101. C
  10102.       DO 10 I=1,NWORD
  10103.       OLDREC(I) = NEWREC(I)
  10104.       NEWREC(I) = BLANKS
  10105.    10 CONTINUE
  10106.       OLDN = NEWN
  10107.       NEWN = 0
  10108.       NEXT = 1
  10109. C
  10110. C     GET 1ST LINE OF INFORMATION
  10111. C
  10112.       IERR = 0
  10113.       NUML = 0
  10114.    15 CONTINUE
  10115.       CALL LXLINE(RECORD,LENREC,NUML,LINE,LEN,LOC)
  10116.       IF(LXEOF) GO TO 7000
  10117. C
  10118. C     CHECK FOR *(SET KEYWORD=NEWVALUE) RECORD
  10119. C
  10120.       CALL LXUSET(LINE,LEN,IFSET)
  10121.       IF(IFSET) GO TO 15
  10122. C
  10123. C     FIND END OF LINE
  10124. C
  10125.       CALL LXEND(LINE,LEN,LOC,MORE,NEWLEN)
  10126. C
  10127. C     GET 1ST ITEM
  10128. C
  10129.       START = 1
  10130.       CALL LXNEXI(LINE,START,NEWLEN)
  10131.       IF(FIRST.NE.0) GO TO 20
  10132. C
  10133. C     NO ITEMS IN LINE 1
  10134. C
  10135.       IF(.NOT.MORE) NOEND = .FALSE.
  10136.       MORE = .TRUE.
  10137.       GO TO 110
  10138.    20 CONTINUE
  10139. C
  10140. C     CHECK FOR GENERATION RECORD
  10141. C
  10142.       IF(TYP.EQ.GENRAT) GO TO 800
  10143. C
  10144. C     BUILD A STRAIGHTFORWARD RECORD
  10145. C
  10146.    30 CONTINUE
  10147.       IF((TYP.NE.SAME) .AND. (TYP.NE.ALLSAM)) GO TO 50
  10148. C
  10149. C     *N OR **
  10150. C
  10151.       NUMI = IVALUE
  10152.       IF(TYP.EQ.ALLSAM) NUMI = OLDN - NEWN
  10153.       IF((NUMI+NEWN).GT.OLDN) GO TO 8010
  10154.       IF(NUMI.LE.0) GO TO 8020
  10155.       IF((NUMI+NEWN).GT.MITEM) GO TO 8030
  10156.       L = NEWN
  10157.       DO 40 J=1,NUMI
  10158.       I = L + J
  10159.       LA = INT(RVAL(I))
  10160.       LB = INTVAL(I)
  10161.       IF(TYPE(I).EQ.TEXT) GO TO 35
  10162.       LA = 1
  10163.       LB = 1
  10164.    35 CONTINUE
  10165.       CALL LXSTOR(TYPE(I),INTVAL(I),RVAL(I),OLDREC(LB),1,LA,.TRUE.)
  10166.       IF(NEWN.GT.MITEM) GO TO 8030
  10167.       IF(NEXT.GT.MCHAR) GO TO 8070
  10168.    40 CONTINUE
  10169.       GO TO 100
  10170.    50 CONTINUE
  10171.       IF(TYP.NE.REPEAT) GO TO 70
  10172. C
  10173. C     *=N
  10174. C
  10175.       NUMI = IVALUE
  10176.       IF(NUMI.LE.0) GO TO 8060
  10177.       IF(NEWN.LE.0) GO TO 8040
  10178.       L = NEWN
  10179.       IF(TGEN.EQ.NULL)IGEN = 0
  10180.       IF(TGEN.EQ.NULL)RGEN = 0.
  10181.       IF((TGEN.NE.NULL).AND.(TGEN.NE.TYPE(L))) GO TO 8080
  10182.       IF((NEWN+NUMI).GT.MITEM) GO TO 8030
  10183.       LA = INT(RVAL(L))
  10184.       LB = INTVAL(L)
  10185.       IF(TYPE(L).EQ.TEXT) GO TO 55
  10186.       LA = 1
  10187.       LB = 1
  10188.    55 CONTINUE
  10189.       RR = RVAL(L)
  10190.       II = INTVAL(L)
  10191.       DO 60 I=1,NUMI
  10192.       RR = RR + RGEN
  10193.       II = II + IGEN
  10194.       CALL LXSTOR(TYPE(L),II,RR,NEWREC(LB),1,LA,.TRUE.)
  10195.       IF(NEWN.GT.MITEM) GO TO 8030
  10196.       IF(NEXT.GT.MCHAR) GO TO 8070
  10197.    60 CONTINUE
  10198.       GO TO 100
  10199.    70 CONTINUE
  10200.       IF(TYP.NE.COMMA) GO TO 80
  10201. C
  10202. C     TYP = COMMA      GENERATE -NULL- TEXT ITEM
  10203. C
  10204.       CALL LXSTOR(TEXT,0,0.,NULL,1,3,.TRUE.)
  10205.       GO TO 100
  10206.    80 CONTINUE
  10207.       IF(TYP.EQ.GENRAT) GO TO 8050
  10208.       CALL LXSTOR(TYP,IVALUE,RVALUE,LINE,FIRST,LAST,.FALSE.)
  10209.       IF(NEWN.GT.MITEM) GO TO 8030
  10210.       IF(NEXT.GT.MCHAR) GO TO 8070
  10211.   100 CONTINUE
  10212.       START = LAST + 1
  10213.       IF(START.GT.NEWLEN) GO TO 110
  10214.       CALL LXNEXI(LINE,START,NEWLEN)
  10215.       IF(FIRST.NE.0) GO TO 30
  10216.   110 CONTINUE
  10217.       IF((.NOT.MORE) .AND. (NEWN.NE.0)) GO TO 1000
  10218. C
  10219. C     GET ANOTHER LINES WORTH
  10220. C
  10221.       CALL LXLINE(RECORD,LENREC,NUML,LINE,LEN,LOC)
  10222.       IF(LXEOF) GO TO 7000
  10223.       CALL LXEND(LINE,LEN,LOC,MORE,NEWLEN)
  10224.       START = 1
  10225.       IF(NOEND) GO TO 120
  10226.       CALL LXNEXI(LINE,START,NEWLEN)
  10227.       IF(FIRST.NE.0) GO TO 30
  10228.       GO TO 110
  10229.   120 CONTINUE
  10230. C
  10231. C     WE EITHER HAVE TO STORE TO THE END OF A QUOTE OR
  10232. C     SKIP TO THE END OF A COMMENT.
  10233. C
  10234.       IF(NEWLEN.LE.0) GO TO 110
  10235.       NOEND = .FALSE.
  10236.       IF(FIRST.NE.0) GO TO 140
  10237. C
  10238. C     COMMENT
  10239. C
  10240.       DO 130 I=1,NEWLEN
  10241.       LAST = I
  10242.       IF(LINE(I).EQ.ENDCOM) GO TO 100
  10243.   130 CONTINUE
  10244.       IF(MORE) NOEND = .TRUE.
  10245.       GO TO 110
  10246.   140 CONTINUE
  10247. C
  10248. C     CONTINUED QUOTE
  10249. C
  10250.       NEXT = INTVAL(NEWN)*NCPW - NCPW + 1 + IFIX(RVAL(NEWN))
  10251.       I = 1
  10252.   150 CONTINUE
  10253.       IF(I.GT.NEWLEN) GO TO 170
  10254.       IF(LINE(I).NE.QUOTES) GO TO 160
  10255.       IF(I.EQ.NEWLEN) GO TO 170
  10256.       IF(LINE(I+1).NE.QUOTES) GO TO 170
  10257.       I = I + 1
  10258.   160 CONTINUE
  10259.       CALL PUTT(NEWREC,NEXT,LINE(I))
  10260.       I = I + 1
  10261.       NEXT = NEXT + 1
  10262.        GO TO 150
  10263.   170 CONTINUE
  10264.       N = NEXT - INTVAL(NEWN)*NCPW + NCPW - 1
  10265.       RVAL(NEWN) = FLOAT(N)
  10266.       LAST = I
  10267.       NEXT = 1 + NCPW*(1+(NEXT-2)/NCPW)
  10268.       IF(MORE.AND.(LAST.GE.NEWLEN)) NOEND = .TRUE.
  10269.       IF(LINE(LAST).EQ.QUOTES) NOEND = .FALSE.
  10270.       GO TO 100
  10271.   800 CONTINUE
  10272. C
  10273. C     PARSE GENERATION RECORD
  10274. C
  10275.       NEWN = OLDN
  10276.       DO 810 I=1,NWORD
  10277.       NEWREC(I) = OLDREC(I)
  10278.   810 CONTINUE
  10279.       CALL LXGENS(RECORD,LENREC,NUML,LINE,LEN,NEWLEN,
  10280.      X         MORE,LOC,IERR)
  10281.       IF(LXEOF) GO TO 7000
  10282.       IF(IERR.EQ.0) GO TO 900
  10283.       NUMREP = 0
  10284.       IF(IERR.EQ.4) GO TO 8040
  10285.       IF(IERR.EQ.6) GO TO 8060
  10286.       IF(LENREC.NE.0) GO TO 1000
  10287.       GO TO 9000
  10288.   900 CONTINUE
  10289. C
  10290. C     STUFF GENERATION RECORD
  10291. C
  10292.       CALL LXGENR
  10293.  1000 CONTINUE
  10294.       RETURN
  10295.  7000 CONTINUE
  10296. C
  10297. C     END OF FILE ENCOUNTERED
  10298. C     RETURN ONE ITEM OF TYPE 3HEOF
  10299. C
  10300.       NEWN = 1
  10301.       TYPE(1) = KYEOF
  10302.       GO TO 1000
  10303.  8000 CONTINUE
  10304. C
  10305. C     ERROR MESSAGES
  10306. C
  10307.  8010 CONTINUE
  10308. C
  10309. C     *N PAST PREVIOUS RECORD
  10310. C
  10311.       IERR = 1
  10312.       IF(LENREC.NE.0) GO TO 1000
  10313.       IF(NOUT.EQ.0) GO TO 9000
  10314.       WRITE (NOUT,8015)
  10315.  8015 FORMAT(17H *** ERROR *** - ,31H*N EXTENDS PAST PREVIOUS RECORD)
  10316.       GO TO 9000
  10317.  8020 CONTINUE
  10318. C
  10319. C     *N OR ** OPTION REQUESTS ZERO OR FEWER ITEMS
  10320. C
  10321.       IERR = 2
  10322.       IF(LENREC.NE.0) GO TO 1000
  10323.       IF(NOUT.EQ.0) GO TO 9000
  10324.       WRITE (NOUT,8025)
  10325.  8025 FORMAT(17H *** ERROR *** -
  10326.      X       ,43H*N OR ** OPTION REQUESTS LESS THAN ONE ITEM)
  10327.       GO TO 9000
  10328.  8030 CONTINUE
  10329. C
  10330. C     MORE THAN MITEM RECORDS
  10331. C
  10332.       IERR = 3
  10333.       IF(LENREC.NE.0) GO TO 1000
  10334.       IF(NOUT.EQ.0) GO TO 9000
  10335.       WRITE (NOUT,8035)MITEM
  10336.  8035 FORMAT(17H *** ERROR *** - ,7HMAX OF ,I3,15H ITEMS EXCEEDED)
  10337.       GO TO 9000
  10338.  8040 CONTINUE
  10339. C
  10340. C     *=N FIRST ITEM
  10341. C
  10342.       IERR = 4
  10343.       IF(LENREC.NE.0) GO TO 1000
  10344.       IF(NOUT.EQ.0) GO TO 9000
  10345.       WRITE (NOUT,8045)
  10346.  8045 FORMAT(17H *** ERROR *** - ,25H*=N MAY NOT BE FIRST ITEM)
  10347.       GO TO 9000
  10348.  8050 CONTINUE
  10349. C
  10350. C     *+N NOT FIRST ITEM IN RECORD
  10351. C
  10352.       IERR = 5
  10353.       IF(LENREC.NE.0) GO TO 1000
  10354.       IF(NOUT.EQ.0) GO TO 9000
  10355.       WRITE (NOUT,8055)
  10356.  8055 FORMAT(17H *** ERROR *** - ,32H*+N MUST BE FIRST ITEM IN RECORD)
  10357.       GO TO 9000
  10358.  8060 CONTINUE
  10359. C
  10360. C     *=N WITH 0 OR NEGATIVE N
  10361. C
  10362.       IERR = 6
  10363.       IF(LENREC.NE.0) GO TO 1000
  10364.       IF(NOUT.EQ.0) GO TO 9000
  10365.       WRITE (NOUT,8065)
  10366.  8065 FORMAT(17H *** ERROR *** - ,28HFOR *=N ITEM N MUST POSITIVE)
  10367.       GO TO 9000
  10368.  8070 CONTINUE
  10369. C
  10370. C     TOTAL TEXT CHARACTERS EXCEEDS MCHAR
  10371. C
  10372.       IERR = 7
  10373.       IF(LENREC.NE.0) GO TO 1000
  10374.       IF(NOUT.EQ.0) GO TO 9000
  10375.       WRITE (NOUT,8075)MCHAR
  10376.  8075 FORMAT(17H *** ERROR *** -
  10377.      X        ,40HTOTAL TEXT CHARACTERS FOR RECORD EXCEEDS ,I4)
  10378.       GO TO 9000
  10379.  8080 CONTINUE
  10380. C
  10381. C     *=N?VALUE DOES NOT AGREE IN TYPE WITH PREVIOUS ITEM.
  10382. C
  10383.       IERR = 8
  10384.       IF(LENREC.NE.0) GO TO 1000
  10385.       IF(NOUT.EQ.0) GO TO 9000
  10386.       WRITE (NOUT,8085)
  10387.  8085 FORMAT(17H *** ERROR *** -
  10388.      X       ,51H*=N VALUE DOES NOT AGREE IN TYPE WITH PREVIOUS ITEM)
  10389.  9000 CONTINUE
  10390.       NEWN = 0
  10391.       IF(.NOT.MORE) GO TO 5
  10392.       IF(TTY(DUM)) GO TO 5
  10393.       CALL LXLINE(RECORD,LENREC,NUML,LINE,LEN,LOC)
  10394.       IF(LXEOF) GO TO 7000
  10395.       CALL LXEND(LINE,LEN,LOC,MORE,NEWLEN)
  10396.       GO TO 9000
  10397.       END
  10398.       FUNCTION LXMASK(NAMEIN)
  10399.         Include TEXT.BLK
  10400.     CHARACTER*4 IBLNK
  10401.     INTEGER*4 IBLANK
  10402.     EQUIVALENCE (IBLNK,IBLANK)
  10403.       DATA IBLNK /' '/
  10404.       NEW = 0
  10405.       DO 10 I=1,8
  10406.       CALL GETT(NAMEIN,I,L)
  10407.       IF(L.NE.IBLANK) CALL PUTT(NEW,I,L)
  10408.    10 CONTINUE
  10409.       LXMASK = NEW
  10410.       RETURN
  10411.       END
  10412.       SUBROUTINE LXNEXI(LINE,START,LEN)
  10413.         Include TEXT.BLK
  10414. C
  10415. C     THIS ROUTINE PARSES THE INPUT LINE RETRIEVING THE NEXT ITEM, IF
  10416. C     ANY, AND DETERMINES THE TYPE AND A VALUE IF NOT A TEXT ITEM.
  10417. C     ITEMS ARE DELIMITED BY BLANKS OR COMMAS.
  10418. C
  10419. C     INPUT  - LINE.....HOLLERITH ARRAY, ONE CHARACTER/WORD.
  10420. C              START....STARTING POINT IN LINE
  10421. C              LEN......LENGTH OF LINE
  10422. C
  10423.         Include LXCIT.BLK
  10424.         Include LXCON.BLK
  10425.       DIMENSION LINE(1)
  10426.       LOGICAL IFINT,IFREAL
  10427.       INTEGER START
  10428. C
  10429. C     LOCATE 1ST CHARACTER
  10430. C
  10431.       NCOMMA = 0
  10432.       NOEND = .FALSE.
  10433.       FIRST = START - 1
  10434.       TYP = TEXT
  10435.    10 CONTINUE
  10436.       FIRST = FIRST + 1
  10437.       LAST = FIRST
  10438.       IF(FIRST.GT.LEN) GO TO 900
  10439.       IF(LINE(FIRST).EQ.BLANK) GO TO 10
  10440.       IF(LINE(FIRST).NE.COMMA) GO TO 12
  10441.       NCOMMA = NCOMMA + 1
  10442.       IF(NCOMMA.LE.1) GO TO 10
  10443.       FIRST = FIRST - 1
  10444.       LAST = FIRST
  10445.       TYP = COMMA
  10446.       GO TO 1000
  10447.    12 CONTINUE
  10448.       IF(LINE(FIRST).EQ.EQUALS) GO TO 1000
  10449.       IF(LINE(FIRST).EQ.LPAREN) GO TO 1000
  10450.       IF(LINE(FIRST).EQ.RPAREN) GO TO 1000
  10451.       IF(LINE(FIRST).NE.STAR) GO TO 20
  10452. C
  10453. C     MIGHT BE COMMENT
  10454. C
  10455.       IF(FIRST.EQ.LEN) GO TO 20
  10456.       ENDCOM = NULL
  10457.       IF(LINE(FIRST+1).EQ.LPAREN) ENDCOM = RPAREN
  10458.       IF(LINE(FIRST+1).EQ.SLASH) ENDCOM = SLASH
  10459.       IF(ENDCOM.EQ.NULL) GO TO 20
  10460. C
  10461. C     TIS - GO UNTIL ")"
  10462. C
  10463.       NOEND = .TRUE.
  10464.       FIRST = FIRST + 1
  10465.    15 CONTINUE
  10466.       FIRST = FIRST + 1
  10467.       IF(FIRST.GT.LEN) GO TO 900
  10468.       IF(LINE(FIRST).NE.ENDCOM) GO TO 15
  10469.       NOEND = .FALSE.
  10470.       GO TO 10
  10471.    20 CONTINUE
  10472. C
  10473. C     LOCATE LAST - 1ST CHECK IF QUOTED STRING
  10474. C
  10475.       IF(LINE(FIRST).EQ.QUOTES) GO TO 50
  10476.       LAST = FIRST
  10477.    30 CONTINUE
  10478. C
  10479. C     LOOK FOR BLANK OR COMMA
  10480. C
  10481.       LAST = LAST + 1
  10482.       IF(LAST.GT.LEN) GO TO 100
  10483.       IF(LINE(LAST).EQ.BLANK) GO TO 100
  10484.       IF(LINE(LAST).EQ.COMMA) GO TO 100
  10485.       IF(LINE(LAST).EQ.LPAREN) GO TO 100
  10486.       IF(LINE(LAST).EQ.RPAREN) GO TO 100
  10487.       IF(LINE(LAST).NE.EQUALS) GO TO 30
  10488. C
  10489. C     SPECIAL CASE *=
  10490. C
  10491.       IF(LAST.NE.(FIRST+1)) GO TO 100
  10492.       IF(LINE(FIRST).NE.STAR) GO TO 100
  10493.       GO TO 30
  10494.    50 CONTINUE
  10495. C
  10496. C     QUOTED STRING
  10497. C
  10498.       NOEND = .TRUE.
  10499.       TYP = TEXT
  10500.       LAST = FIRST
  10501.    60 CONTINUE
  10502.       IF(LAST.GE.LEN) GO TO 1000
  10503.       LAST = LAST + 1
  10504.       IF(LINE(LAST).NE.QUOTES) GO TO 60
  10505.       IF(LAST.EQ.LEN) GO TO 70
  10506.       IF(LINE(LAST+1).NE.QUOTES)GO TO 70
  10507.       LAST = LAST + 1
  10508.       GO TO 60
  10509.    70 CONTINUE
  10510.       NOEND = .FALSE.
  10511.       GO TO 1000
  10512.   100 CONTINUE
  10513. C
  10514. C     TEST FOR REAL OR INTEGER
  10515. C
  10516.       LAST = LAST -1
  10517.       TYP = INTGER
  10518.       CALL LXGETI(LINE(FIRST),LAST-FIRST+1,IFINT,IVALUE)
  10519.       IF(IFINT) GO TO 1000
  10520.       IVALUE = 0
  10521.       TYP = REAL
  10522.       CALL LXGETR(LINE(FIRST),LAST-FIRST+1,IFREAL,RVALUE)
  10523.       IF(IFREAL) GO TO 1000
  10524.       RVALUE = 0.
  10525. C
  10526. C     TRY FOR SPECIALTY TYPES
  10527. C
  10528.       TYP = TEXT
  10529.       IF(LINE(FIRST).NE.STAR) GO TO 1000
  10530.       IF(FIRST.NE.LAST) GO TO 105
  10531. C
  10532. C     SINGLE *
  10533. C
  10534.       TYP = SAME
  10535.       IVALUE = 1
  10536.       GO TO 1000
  10537.   105 CONTINUE
  10538.       IF(LINE(FIRST+1).NE.STAR) GO TO 110
  10539.       IF(LAST.NE.FIRST+1) GO TO 110
  10540. C
  10541. C     **, *=N, *+N THEN *N
  10542. C
  10543.       TYP = ALLSAM
  10544.       GO TO 1000
  10545.   110 CONTINUE
  10546.       IF((LAST-FIRST).LE.1) GO TO 130
  10547.       IF(LINE(FIRST+1).NE.EQUALS) GO TO 120
  10548. C
  10549. C     *=N - SEE IF *=N?VALUE
  10550. C
  10551.       TGEN = NULL
  10552.       IGEN = 0
  10553.       RGEN = 0.
  10554.       NUM = LAST - FIRST - 2
  10555.       IF(NUM.LE.0) GO TO 114
  10556.       LOOK = FIRST + 2
  10557.       DO 112 I=1,NUM
  10558.       LOOK = LOOK + 1
  10559.       IF(LINE(LOOK) .EQ. PLUS) GO TO 200
  10560.       IF(LINE(LOOK) .EQ. MINUS) GO TO 200
  10561.   112 CONTINUE
  10562.   114 CONTINUE
  10563. C
  10564. C     PLAIN *=N
  10565. C
  10566.       CALL LXGETI(LINE(FIRST+2),LAST-FIRST-1,IFINT,IVALUE)
  10567.       TYP = REPEAT
  10568.       IF(IFINT) GO TO 1000
  10569.       TYP = TEXT
  10570.       IVALUE = 0
  10571.       GO TO 1000
  10572.   120 CONTINUE
  10573.       IF(LINE(FIRST+1).NE.PLUS) GO TO 130
  10574.       CALL LXGETI(LINE(FIRST+2),LAST-FIRST-1,IFINT,IVALUE)
  10575.       TYP = GENRAT
  10576.       IF(IFINT) GO TO 1000
  10577.   130 CONTINUE
  10578. C
  10579. C     *N
  10580. C
  10581.       TYP = SAME
  10582.       CALL LXGETI(LINE(FIRST+1),LAST-FIRST,IFINT,IVALUE)
  10583.       IF(IFINT) GO TO 1000
  10584.       TYP = TEXT
  10585.       IVALUE = 0
  10586.       GO TO 1000
  10587.   200 CONTINUE
  10588. C
  10589. C     *=N?VALUE
  10590. C
  10591.       TYP = REPEAT
  10592.       CALL LXGETI(LINE(FIRST+2),LOOK-FIRST-2,IFINT,IVALUE)
  10593.       IF(.NOT.IFINT) GO TO 250
  10594.       TGEN = INTGER
  10595.       CALL LXGETI(LINE(LOOK),LAST-LOOK+1,IFINT,IGEN)
  10596.       IF(IFINT) GO TO 1000
  10597.       TGEN = REAL
  10598.       CALL LXGETR(LINE(LOOK),LAST-LOOK+1,IFREAL,RGEN)
  10599.       IF(IFREAL) GO TO 1000
  10600.   250 CONTINUE
  10601.       TYP = TEXT
  10602.       IVALUE = 0
  10603.       GO TO 1000
  10604.   900 CONTINUE
  10605. C
  10606. C     COULDNT FIND AN ITEM
  10607. C
  10608.       FIRST = 0
  10609.  1000 CONTINUE
  10610.       RETURN
  10611.       END
  10612.       SUBROUTINE LXSET(WHAT,NEWVAL)
  10613.         Include TEXT.BLK
  10614. C
  10615. C     THIS ROUTINE IS USED TO RESET PARAMETERS FOR THE LXLREC
  10616. C     GROUP OF ROUTINES.
  10617. C
  10618. C     INPUT  - WHAT.....WHICH PARAMETER TO RESET
  10619. C              NEWVAL...NEW VALUE FOR PARAMETER
  10620. C
  10621. C     POSSIBLE VALUES FOR WHAT
  10622. C       WHAT                                      NEWVAL
  10623. C       ----                                      ------
  10624. C     4HECHO                                      2HON,3HOFF
  10625. C     4HPROM                                      PROMPT CHARACTERS
  10626. C     4HINPT                                      INFIL NAME/NUMBER
  10627. C     4HOTPT                                      OUTFILE NAME/NUMBER
  10628. C     4HDOLL (DOLLAR END-OF-RECORD)               SEE NOTE
  10629. C     4HCOMM (COMMA ITEM DELIMETER)               SEE NOTE
  10630. C     4HSEMI (SEMI-COLON END-OF-RECORD)           SEE NOTE
  10631. C     4HBLAN (BLANK ITEM DELIMITER)               SEE NOTE
  10632. C     4HPLUS (PLUS CONTINUATION CHARACTER)        SEE NOTE
  10633. C     4HQUOT (TEXT ITEM DELIMETER)                SEE NOTE
  10634. C
  10635. C     NOTE - FOR CHARACTER PARAMETERS SUCH AS DOLLAR, THE CHARRACTER
  10636. C            PARAMETER WILL BE REPLACED WITH THE 1ST CHARACTER IN
  10637. C            NEWVAL UNLESS NEWVAL IS NULL.  IN THAT CASE, DOLLAR
  10638. C            WILL NOT BE AN END-OF-RECORD CHARACTER AND WILL NOT BE
  10639. C            REPLACED BY ANY OTHER CHARACTER.
  10640. C
  10641.         Include LXCON.BLK
  10642.         Include PROM.BLK
  10643.         Include LXCARD.BLK
  10644.         Include LXWRDS.BLK
  10645.       LOGICAL IFNULL
  10646.       INTEGER WHAT
  10647.       DATA ISAVPR /1/
  10648.       DATA JSAVPR /1/
  10649.       IF(WHAT.NE.KYECHO) GO TO 10
  10650. C
  10651. C     ECHO OPTION
  10652. C
  10653.       IF(NEWVAL.EQ.KYON) ECHO = .TRUE.
  10654.       IF(NEWVAL.EQ.KYOFF) ECHO = .FALSE.
  10655.       GO TO 1000
  10656.    10 CONTINUE
  10657.       IF(WHAT.NE.KYPROM) GO TO 15
  10658. C
  10659. C     PROMPT OPTION
  10660. C
  10661.       JSAVPR = ISAVPR
  10662.       ISAVPR = NEWVAL
  10663.       PROM = NEWVAL
  10664.       GO TO 1000
  10665.    15 CONTINUE
  10666.       IF(WHAT.NE.KYINPT) GO TO 20
  10667. C
  10668. C     INPUT FILE NAME
  10669. C
  10670.       NIN = NEWVAL
  10671.       GO TO 1000
  10672.    20 CONTINUE
  10673.       IF(WHAT.NE.KYOTPT) GO TO 30
  10674. C
  10675. C     OUTPUT FILE NAME
  10676. C
  10677.       NOUT = NEWVAL
  10678.       GO TO 1000
  10679.    30 CONTINUE
  10680.       IFNULL = .FALSE.
  10681.       IF(NEWVAL.EQ.NULL) IFNULL = .TRUE.
  10682.       CALL GETT(NEWVAL,1,ICHAR)
  10683.       IF(WHAT.NE.KYDOLL) GO TO 40
  10684. C
  10685. C     DOLLAR
  10686. C
  10687.       DOLLAR = ICHAR
  10688.       IF(IFNULL)DOLLAR = NULL
  10689.       GO TO 1000
  10690.    40 CONTINUE
  10691.       IF(WHAT.NE.KYSEMI) GO TO 50
  10692. C
  10693. C     SEMI-COLON
  10694. C
  10695.       SEMI = ICHAR
  10696.       IF(IFNULL)SEMI = NULL
  10697.       GO TO 1000
  10698.    50 CONTINUE
  10699.       IF(WHAT.NE.KYCOMM) GO TO 60
  10700. C
  10701. C     COMMA
  10702. C
  10703.       COMMA = ICHAR
  10704.       IF(IFNULL)COMMA = NULL
  10705.       GO TO 1000
  10706.    60 CONTINUE
  10707.       IF(WHAT.NE.KYBLAN) GO TO 70
  10708. C
  10709. C     BLANK
  10710. C
  10711.       BLANK = ICHAR
  10712.       IF(IFNULL)BLANK = NULL
  10713.       GO TO 1000
  10714.    70 CONTINUE
  10715.       IF(WHAT.NE.KYPLUS) GO TO 80
  10716. C
  10717. C     PLUS
  10718. C
  10719.       CONT = ICHAR
  10720.       IF(IFNULL)CONT = NULL
  10721.       GO TO 1000
  10722.    80 CONTINUE
  10723. C
  10724. C     QUOTES
  10725. C
  10726.       IF(WHAT.NE.KYQUOT) GO TO 90
  10727.       QUOTES = ICHAR
  10728.       IF(IFNULL) QUOTES = NULL
  10729.       GO TO 1000
  10730.    90 CONTINUE
  10731.       IF(WHAT.NE.KYPRES) GO TO 100
  10732.       IF(JSAVPR.EQ.1) GO TO 100
  10733.       PROM = JSAVPR
  10734.       ITEMP = JSAVPR
  10735.       JSAVPR = ISAVPR
  10736.       ISAVPR = ITEMP
  10737.       GO TO 1000
  10738.   100 CONTINUE
  10739.  1000 CONTINUE
  10740.       RETURN
  10741.       END
  10742.       SUBROUTINE LXSREC(I,CHAR1,NUMC,STRING,START)
  10743.         Include TEXT.BLK
  10744. C
  10745. C     THIS SUBROUTINE PUTS NUMC CHARACTERS FROM THE I'TH
  10746. C     ITEM INTO STRING STARTING WITH CHAR1 IN ITEM AND
  10747. C     START IN STRING.  THE STRING IS BLANK FILLED IF
  10748. C     THERE IS NOT ENOUGH ITEM OR SET TO ALL BLANKS IF
  10749. C     ITEM IS NOT A VALID TEXT ITEM.
  10750. C
  10751.         Include LXCON.BLK
  10752.         Include LXCARD.BLK
  10753.       INTEGER CHAR1,START,STRING(1)
  10754.       NUMB = NUMC
  10755.       ISB = START
  10756.       IF(I.LT.1) GO TO 1000
  10757.       IF(I.GT.NEWN) GO TO 1000
  10758.       IF(CHAR1.LT.1) GO TO 100
  10759.       IF(START.LT.1) GO TO 100
  10760.       IF(TYPE(I).NE.TEXT) GO TO 1000
  10761.       LEN = INT(RVAL(I))
  10762.       IF(CHAR1.GT.LEN) GO TO 100
  10763.       ISC = INTVAL(I)
  10764.       NUM = LEN - CHAR1 + 1
  10765.       IF(NUMC.LT.NUM) NUM = NUMC
  10766.       NUMB = NUMC - NUM
  10767.       ISB = START + NUM
  10768.       CALL STRMOV(NEWREC(ISC),CHAR1,NUM,STRING,START)
  10769.   100 CONTINUE
  10770. C
  10771. C     BLANK FILL
  10772. C
  10773.       DO 110 II=1,NUMB
  10774.       CALL PUTT(STRING,ISB,BLANKS)
  10775.       ISB = ISB + 1
  10776.   110 CONTINUE
  10777.       RETURN
  10778.  1000 CONTINUE
  10779. C
  10780. C     PUT -0- IN TEXT STRING
  10781. C
  10782.       NUM = 3
  10783.       IF(NUMC.LT.NUM) NUM = NUMC
  10784.       CALL STRMOV(NULL,1,NUM,STRING,START)
  10785.       NUMB = NUMC - NUM
  10786.       ISB = START + NUM
  10787.       IF(NUMB.GT.0) GO TO 100
  10788.       RETURN
  10789.       END
  10790.       SUBROUTINE LXSTOR(TYP,I,R,LINE,FIRST,LAST,STRING)
  10791.         Include TEXT.BLK
  10792. C
  10793. C     THIS ROUTINE STORES AN ITEM IN NEWREC.
  10794. C
  10795. C     INPUT - TYP.....ITEM TYP
  10796. C             I.......ITEM INTEGER VALUE IF INTGER
  10797. C             R.......ITEM REAL VALUE IF REAL
  10798. C             LINE....TEXT STRING
  10799. C             FIRST...FIRST CHARACTER OF TEXT IN LINE
  10800. C             LAST....LAST CHARACTER OF TEXT IN LINE
  10801. C             STRING..LOGICAL .TRUE. IF LINE IS PACKED.
  10802. C                             .FALSE. IF LINE IS ONE CHAR PER WORD.
  10803. C
  10804.         Include LXCARD.BLK
  10805.         Include LXCON.BLK
  10806.       LOGICAL STRING
  10807.       INTEGER TYP,FIRST,LAST
  10808.       DIMENSION LINE(1)
  10809.       NEWN = NEWN + 1
  10810.       IF(NEWN.GT.MITEM) GO TO 1000
  10811.       TYPE(NEWN) = TYP
  10812.       IF(TYP.NE.INTGER) GO TO 50
  10813. C
  10814. C     INTEGER
  10815. C
  10816.       INTVAL(NEWN) = I
  10817.       RVAL(NEWN) = 0.
  10818.       GO TO 1000
  10819.    50 CONTINUE
  10820.       IF(TYP.NE.REAL) GO TO 100
  10821. C
  10822. C     REAL
  10823. C
  10824.       RVAL(NEWN) = R
  10825.       INTVAL(NEWN) = 0
  10826.       GO TO 1000
  10827.   100 CONTINUE
  10828.       IF(TYP.NE.TEXT) GO TO 1000
  10829. C
  10830. C     TEXT - BRANCH IF STRING OR ONE CHAR. PER WORD
  10831. C
  10832.       IF(STRING) GO TO 200
  10833. C
  10834. C     CHECK FOR LEADING AND TRAILING QUOTES
  10835. C
  10836.       I1 = FIRST
  10837.       I2 = LAST
  10838.       IF(LINE(I1).EQ.QUOTES) I1 = I1 + 1
  10839.       IF(LINE(I2).EQ.QUOTES) I2 = I2 - 1
  10840.       INTVAL(NEWN) = 1 + NEXT/NCPW
  10841.       IF(I1.GT.I2) GO TO 150
  10842.       J = I1 - 1
  10843.   110 CONTINUE
  10844.       J = J + 1
  10845.       IF(J.EQ.I2) GO TO 120
  10846.       IF(LINE(J) .NE. QUOTES) GO TO 120
  10847.       IF(LINE(J+1) .NE. QUOTES) GO TO 120
  10848.       J = J + 1
  10849.   120 CONTINUE
  10850.       CALL PUTT(NEWREC,NEXT,LINE(J))
  10851.       NEXT = NEXT + 1
  10852.       IF(NEXT.GT.MCHAR) GO TO 1000
  10853.       IF(J.LT.I2) GO TO 110
  10854.   150 CONTINUE
  10855.       GO TO 270
  10856.   200 CONTINUE
  10857. C
  10858. C     STRING - JUST MOVE IT
  10859. C
  10860.       INTVAL(NEWN) = 1 + NEXT/NCPW
  10861.       DO 250 J=FIRST,LAST
  10862.       CALL GETT(LINE,J,IWORD)
  10863.       CALL PUTT(NEWREC,NEXT,IWORD)
  10864.       NEXT = NEXT + 1
  10865.       IF(NEXT.GT.MCHAR) GO TO 1000
  10866.   250 CONTINUE
  10867.   270 CONTINUE
  10868.       LEN = NEXT - INTVAL(NEWN)*NCPW + NCPW - 1
  10869.       RVAL(NEWN) = FLOAT(LEN)
  10870.       NEXT = 1 + NCPW*(1+(NEXT-2)/NCPW)
  10871.  1000 CONTINUE
  10872.       RETURN
  10873.       END
  10874.       SUBROUTINE LXUSET(LINE,LEN,IFSET)
  10875.         Include TEXT.BLK
  10876. C
  10877. C     THSI ROUTINE CHECKS LINE FOR A USER SET COMMENT.  THESE COMMENTS
  10878. C     ARE OF THE FORM  *(SET KEYWORD=NEWVALUE)
  10879. C     WHERE KEYWORD CAN BE    DOLLAR
  10880. C                             SEMI
  10881. C                             QUOTES
  10882. C                             BLANK
  10883. C                             PLUS
  10884. C                             COMMA
  10885. C                             ECHO
  10886. C     NEWVALUE IS EITHER THE NEW CHARACTER OR THE WORD NULL EXCEPT
  10887. C     ECHO WHICH TAKES ON OR OFF.
  10888. C
  10889. C     INPUT  - LINE - ONE CHARACTER PER WORD
  10890. C              LEN  - LENGTH OF LINE
  10891. C     OUTPUT - IFSET- .TRUE. IF LEN IS BETWEEN 13 AND 18 AND
  10892. C                     THE LINE START *(SET  AND ENDS WITH ).
  10893. C
  10894.         Include LXCON.BLK
  10895.         Include LXCARD.BLK
  10896.         Include LXWRDS.BLK
  10897.       LOGICAL IFSET
  10898.       DIMENSION LINE(LEN)
  10899.       IFSET = .FALSE.
  10900. C
  10901. C     ELIMINATE ANYTHING ELSE
  10902. C
  10903.       IF(LEN.LT.13) GO TO 1000
  10904.       IF(LEN.GT.18) GO TO 1000
  10905.       IF(LINE(1).NE.STAR) GO TO 1000
  10906.       IF(LINE(2).NE.LPAREN) GO TO 1000
  10907.       IF(LINE(3).NE.KYS) GO TO 1000
  10908.       IF(LINE(4).NE.E) GO TO 1000
  10909.       IF(LINE(5).NE.KYT) GO TO 1000
  10910.       IF(LINE(6).NE.BLANKS) GO TO 1000
  10911.       IF(LINE(LEN).NE.RPAREN) GO TO 1000
  10912. C
  10913. C     FOUND A SET COMMAND
  10914. C
  10915.       IFSET = .TRUE.
  10916. C
  10917. C     SEE IF ECHO COMMAND
  10918. C
  10919.       IF(LINE(7).NE.E) GO TO 5
  10920.       IF(LINE(8).NE.KYC) GO TO 5
  10921.       IF(LINE(9).NE.KYH) GO TO 5
  10922.       IF(LINE(10).EQ.KYO) GO TO 800
  10923.     5 CONTINUE
  10924. C
  10925. C     LOOK BETWEEN = AND END FOR NULL OR SINGLE CHARACTER
  10926. C
  10927.       IE = 10
  10928.       DO 10 I=1,3
  10929.       IE = IE + 1
  10930.       IF(LINE(IE).EQ.EQUALS) GO TO 20
  10931.    10 CONTINUE
  10932.       GO TO 900
  10933.    20 CONTINUE
  10934.       NUM = LEN - IE - 1
  10935.       NEWVAL = LINE(IE+1)
  10936.       IF(NUM.EQ.1) GO TO 50
  10937.       IF(NUM.NE.4) GO TO 900
  10938. C
  10939. C     CHECK FOR NULL
  10940. C
  10941.       NEWVAL = NULL
  10942.       IF(LINE(IE+1).NE.KYN) GO TO 900
  10943.       IF(LINE(IE+2).NE.KYU) GO TO 900
  10944.       IF(LINE(IE+3).NE.KYL) GO TO 900
  10945.       IF(LINE(IE+4).NE.KYL) GO TO 900
  10946.    50 CONTINUE
  10947.       IF(LINE(7).NE.KYC) GO TO 100
  10948. C
  10949. C     COMMA
  10950. C
  10951.       IF(LINE(8).NE.KYO) GO TO 900
  10952.       IF(LINE(9).NE.KYM) GO TO 900
  10953.       IF(LINE(10).NE.KYM) GO TO 900
  10954.       IF(LINE(11).NE.KYA) GO TO 900
  10955.       COMMA = NEWVAL
  10956.       GO TO 1000
  10957.   100 CONTINUE
  10958.       IF(LINE(7).NE.KYD) GO TO 150
  10959. C
  10960. C     DOLLAR
  10961. C
  10962.       IF(LINE(8).NE.KYO) GO TO 900
  10963.       IF(LINE(9).NE.KYL) GO TO 900
  10964.       IF(LINE(10).NE.KYL) GO TO 900
  10965.       IF(LINE(11).NE.KYA) GO TO 900
  10966.       IF(LINE(12).NE.KYR) GO TO 900
  10967.       DOLLAR = NEWVAL
  10968.       GO TO 1000
  10969.   150 CONTINUE
  10970.       IF(LINE(7).NE.KYB) GO TO 200
  10971. C
  10972. C     BLANK
  10973. C
  10974.       IF(LINE(8).NE.KYL) GO TO 900
  10975.       IF(LINE(9).NE.KYA) GO TO 900
  10976.       IF(LINE(10).NE.KYN) GO TO 900
  10977.       IF(LINE(11).NE.KYK) GO TO 900
  10978.       BLANK = NEWVAL
  10979.       GO TO 1000
  10980.  
  10981.   200 CONTINUE
  10982.       IF(LINE(7).NE.KYP) GO TO 250
  10983. C
  10984. C     PLUS
  10985. C
  10986.       IF(LINE(8).NE.KYL) GO TO 900
  10987.       IF(LINE(9).NE.KYU) GO TO 900
  10988.       IF(LINE(10).NE.KYS) GO TO 900
  10989.       PLUS = NEWVAL
  10990.       GO TO 1000
  10991.   250 CONTINUE
  10992.       IF(LINE(7).NE.KYQ) GO TO 300
  10993. C
  10994. C     QUOTES
  10995. C
  10996.       IF(LINE(8).NE.KYU) GO TO 900
  10997.       IF(LINE(9).NE.KYO) GO TO 900
  10998.       IF(LINE(10).NE.KYT) GO TO 900
  10999.       IF(LINE(11).NE.KYE) GO TO 900
  11000.       IF(LINE(12).NE.KYS) GO TO 900
  11001.       QUOTES = NEWVAL
  11002.       GO TO 1000
  11003.   300 CONTINUE
  11004. C
  11005. C     SEMI
  11006. C
  11007.       IF(LINE(7).NE.KYS) GO TO 900
  11008.       IF(LINE(8).NE.E) GO TO 900
  11009.       IF(LINE(9).NE.KYM) GO TO 900
  11010.       IF(LINE(10).NE.KYI) GO TO 900
  11011.       SEMI = NEWVAL
  11012.       GO TO 1000
  11013.   800 CONTINUE
  11014. C
  11015. C     ECHO
  11016. C
  11017.       IF(LINE(12).NE.KYO) GO TO 900
  11018.       IF(LINE(13).NE.KYF) GO TO 850
  11019. C
  11020. C     OFF
  11021. C
  11022.       IF(LEN.NE.15) GO TO 900
  11023.       IF(LINE(14).NE.KYF) GO TO 900
  11024.       ECHO = .FALSE.
  11025.       GO TO 1000
  11026.   850 CONTINUE
  11027. C
  11028. C     ON
  11029. C
  11030.       IF(LEN.NE.14) GO TO 900
  11031.       IF(LINE(13).NE.KYN) GO TO 900
  11032.       ECHO = .TRUE.
  11033.       GO TO 1000
  11034.   900 CONTINUE
  11035. C
  11036. C     UNRECOGNIZABLE SET COMMAND
  11037. C
  11038.       IF(NOUT.NE.0)WRITE(NOUT,910)
  11039.   910 FORMAT(46H *** WARNING *** DID NOT RECOGNIZE SET COMMAND)
  11040.  1000 CONTINUE
  11041.       RETURN
  11042.       END
  11043.       FUNCTION LXWREC(I,J)
  11044.         Include TEXT.BLK
  11045. C
  11046. C     THIS FUNCTION RETURNS THE JTH WORD OF ITEM I IF TEXT
  11047. C     IF I IS NOT A VALID TEXT ITEM BLANKS ARE RETURNED.
  11048. C
  11049.         Include LXCARD.BLK
  11050.         Include LXCON.BLK
  11051.       LXWREC = BLANKS
  11052.       IF(I.LT.1) RETURN
  11053.       IF(I.GT.NEWN) RETURN
  11054.       IF(J.LT.1) RETURN
  11055.       IF(TYPE(I).NE.TEXT) RETURN
  11056.       LEN = INT(RVAL(I))
  11057.       I1 = (J-1)*NCPW
  11058.       IF(I1.GE.LEN) RETURN
  11059.       K = INTVAL(I) + J - 1
  11060.       LXWREC = NEWREC(K)
  11061.       RETURN
  11062.       END
  11063.       SUBROUTINE MINMAX(MMVAL,MMTYP)
  11064.         Include TEXT.BLK
  11065. C
  11066. C  PURPOSE:  PROCESS THE MIN/MAX REQUESTS
  11067. C
  11068. C  PARAMETERS: MMVAL--MIN/MAX VALUE
  11069. C              MMTYP--3HMIN OR 3HMAX (REQUEST TYPE)
  11070. C
  11071.         Include RMATTS.BLK
  11072.         Include CONST4.BLK
  11073.         Include BTBUF.BLK
  11074.         Include BUFFER.BLK
  11075.         Include F3COM.BLK
  11076.         Include TUPLEA.BLK
  11077.         Include RIMCOM.BLK
  11078.         Include MISC.BLK
  11079. C
  11080.       DIMENSION MMVAL(1)
  11081.       EQUIVALENCE (IMVAL,RMVAL)
  11082.       EQUIVALENCE (IV,RV)
  11083.       CALL TYPER(ATTYPE,MATVEC,ITYPE)
  11084.       MMVAL(1) = NULL
  11085. C
  11086. C  CHECK FOR A KEYED ATTRIBUTE
  11087. C
  11088.       IF(ATTKEY.NE.0) GO TO 300
  11089. C
  11090. C  NON-KEYED ATTRIBUTE -- PROCESS THE FUNCTION
  11091. C
  11092.   100 CALL RMLOOK(IP,1,1,LEN)
  11093.       IF(RMSTAT.NE.0) GO TO 998
  11094.       MMVAL(1) = BUFFER(IP+ATTCOL-1)
  11095.       MMVAL(2) = BUFFER(IP+ATTCOL)
  11096.       IF(MMVAL(1).EQ.NULL) GO TO 100
  11097.   200 CALL RMLOOK(IP,1,1,LEN)
  11098.       IF(RMSTAT.NE.0) GO TO 998
  11099.       IV = BUFFER(IP+ATTCOL-1)
  11100.       IF(IV.EQ.NULL) GO TO 200
  11101.       IF((ITYPE.EQ.KZDOUB).OR.(ITYPE.EQ.KZREAL)) GO TO 210
  11102.       IF((MMTYP.EQ.K4MIN).AND.(IV.GT.MMVAL(1))) GO TO 200
  11103.       IF((MMTYP.EQ.K4MAX).AND.(IV.LT.MMVAL(1))) GO TO 200
  11104.       GO TO 220
  11105.   210 CONTINUE
  11106.       IMVAL = MMVAL(1)
  11107.       IF((MMTYP.EQ.K4MIN).AND.(RV.GT.RMVAL)) GO TO 200
  11108.       IF((MMTYP.EQ.K4MAX).AND.(RV.LT.RMVAL)) GO TO 200
  11109.   220 CONTINUE
  11110.       MMVAL(1) = IV
  11111.       MMVAL(2) = BUFFER(IP+ATTCOL)
  11112.       GO TO 200
  11113. C
  11114. C  KEYED ATTRIBUTE -- PROCESS THE FUNCTION
  11115. C
  11116.   300 IF(MMTYP.EQ.K4MAX) GO TO 400
  11117. C
  11118. C  GET THE MIN VALUE FROM THE BTREE
  11119. C
  11120.       KSTART = ATTKEY
  11121.   310 CALL BTGET(KSTART,IN)
  11122.       IF(VALUE(2,IN).GE.0) GO TO 320
  11123. C
  11124. C  GET THE NEXT NODE
  11125. C
  11126.       KSTART = -VALUE(2,IN)
  11127.       GO TO 310
  11128. C
  11129. C  WE FOUND THE MINIMUM
  11130. C
  11131.   320 CONTINUE
  11132.       MMVAL(1) = VALUE(1,IN)
  11133.       IF(ATTYPE.NE.KZDOUB) GO TO 998
  11134.       CALL GETDAT(1,VALUE(2,IN),IP,LEN)
  11135.       MMVAL(1) = BUFFER(IP+ATTCOL-1)
  11136.       MMVAL(2) = BUFFER(IP+ATTCOL)
  11137.       GO TO 998
  11138. C
  11139. C  GET THE MAXIMUM VALUE FROM THE BTREE
  11140. C
  11141.   400 CONTINUE
  11142.       KSTART = ATTKEY
  11143.   410 CALL BTGET(KSTART,IN)
  11144.       KEND = IN + (LENBF3/3) - 1
  11145.       DO 420 J=IN,KEND
  11146.       IF(VALUE(1,J).EQ.ENDWRD) GO TO 430
  11147.   420 CONTINUE
  11148.       GO TO 998
  11149. C
  11150. C  CHECK IF WE REACHED THE BOTTOM NODE
  11151. C
  11152.   430 CONTINUE
  11153.       IF(VALUE(2,J).GE.0) GO TO 440
  11154. C
  11155. C  GET THE NEXT NODE
  11156. C
  11157.       KSTART = -VALUE(2,J)
  11158.       GO TO 410
  11159. C
  11160. C  FOUND THE MAXIMUM NODE
  11161. C
  11162.   440 CONTINUE
  11163.       MMVAL(1) = VALUE(1,J-1)
  11164.       IF(ATTYPE.NE.KZDOUB) GO TO 998
  11165.       CALL GETDAT(1,VALUE(2,J-1),IP,LEN)
  11166.       MMVAL(1) = BUFFER(IP+ATTCOL-1)
  11167.       MMVAL(2) = BUFFER(IP+ATTCOL)
  11168.       GO TO 998
  11169. C
  11170. C  CHECK THAT A VALUE WAS OBTAINED
  11171. C
  11172.   998 CONTINUE
  11173.       RMSTAT = 0
  11174.       IF(MMVAL(1).NE.NULL) GO TO 999
  11175. C
  11176. C  ERROR - NULL VALUE
  11177. C
  11178.       RMSTAT = 44
  11179.   999 CONTINUE
  11180.       RETURN
  11181.       END
  11182.       SUBROUTINE MODIFY
  11183.         Include TEXT.BLK
  11184. C
  11185. C  THIS ROUTINE IS THE DRIVER FOR MODIFY OF THE RIM DATA BASE.
  11186. C
  11187.         Include CONST8.BLK
  11188.         Include RMKEYW.BLK
  11189.         Include RIMCOM.BLK
  11190.         Include TUPLEA.BLK
  11191.         Include TUPLER.BLK
  11192.         Include ATTBLE.BLK
  11193.         Include FLAGS.BLK
  11194.         Include BUFFER.BLK
  11195.         Include FILES.BLK
  11196.         Include MISC.BLK
  11197.       LOGICAL EQKEYW
  11198.       LOGICAL NE
  11199.       LOGICAL EQ
  11200.         Include DCLAR1.BLK
  11201.         Include DCLAR6.BLK
  11202.       NEXTOP = K8READ
  11203. C
  11204. C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
  11205. C
  11206.       CALL RMDBLK(DBNAME)
  11207.       IF(RMSTAT.EQ.0) GO TO 200
  11208.       CALL WARN(RMSTAT,DBNAME,0)
  11209.       GO TO 5000
  11210. C
  11211. C  READ A CARD
  11212. C
  11213.   100 CONTINUE
  11214.       CALL LODREC
  11215. C
  11216. C  SCAN A COMMAND.
  11217. C
  11218.   200 CONTINUE
  11219.       IFMOD = .TRUE.
  11220.       ITEMS = LXITEM(NUM)
  11221.       IF(EQKEYW(1,KWCHAN,6)) GO TO 400
  11222.       IF(EQKEYW(1,KWRENA,6)) GO TO 1000
  11223.       IF(EQKEYW(1,KWREMO,6)) GO TO 2000
  11224.       IF(EQKEYW(1,KWDELE,6)) GO TO 3000
  11225. C
  11226. C  UNRECOGNIZED COMMAND.
  11227. C
  11228.   300 CONTINUE
  11229.       NEXTOP = K8USE
  11230.       GO TO 5000
  11231. C
  11232. C  *************************
  11233. C  CHANGE COMMAND.
  11234. C  *************************
  11235. C
  11236.   400 CONTINUE
  11237.       IF(ITEMS.LT.4) GO TO 4000
  11238.       ITO = LFIND(1,ITEMS,KWTO,2)
  11239.       IF(ITO.LT.3) GO TO 4000
  11240.       IF(ITO.GT.7) GO TO 4000
  11241. C
  11242. C     LOOK FOR CHANGE OWNER
  11243. C
  11244.       IF(EQKEYW(2,KWOWNE,5)) GO TO 1005
  11245. C
  11246. C  SEE IF THIS IS A CHANGE FOR PASSWORDS.
  11247. C
  11248.       IF(EQKEYW(2,KWRPW,3)) GO TO 410
  11249.       IF(EQKEYW(2,KWMPW,3)) GO TO 410
  11250.       GO TO 450
  11251. C
  11252. C  CHANGE THE PASSWORDS.
  11253. C
  11254.   410 CONTINUE
  11255.       IF(ITO.NE.3) GO TO 4000
  11256.       IF(.NOT.EQKEYW(5,KWFOR,3)) GO TO 4000
  11257.       IF(ITEMS.NE.6) GO TO 4000
  11258.       RNAME = BLANK
  11259.       CALL LXSREC(6,1,8,RNAME,1)
  11260.       I = LOCREL(RNAME)
  11261.       IF(I.EQ.0) GO TO 420
  11262.       CALL WARN(1,RNAME,0)
  11263.       GO TO 100
  11264.   420 CONTINUE
  11265.       L = LOCPRM(RNAME,2)
  11266.       IF(L.NE.0) GO TO 4500
  11267.       IF((LXLENC(4).GE.1).AND.(LXLENC(4).LE.8)) GO TO 425
  11268.       WRITE(NOUT,422)
  11269.   422 FORMAT(44H -ERROR- PASSWORDS MUST BE 1-8 ALPHANUMERIC ,
  11270.      X       10HCHARACTERS)
  11271.       GO TO 100
  11272.   425 CONTINUE
  11273.       CALL RELGET(ISTAT)
  11274. C
  11275. C  CHANGE THE PASSWORD.
  11276. C
  11277.       IF(.NOT.EQKEYW(2,KWRPW,3)) GO TO 430
  11278.       RPW = BLANK
  11279.       CALL LXSREC(4,1,8,RPW,1)
  11280.       GO TO 440
  11281.   430 CONTINUE
  11282.       MPW = BLANK
  11283.       CALL LXSREC(4,1,8,MPW,1)
  11284.   440 CONTINUE
  11285.       CALL RELPUT
  11286.       GO TO 100
  11287.   450 CONTINUE
  11288. C
  11289. C  DEFINE THE BUFFERS FOR CHANGE
  11290. C
  11291.       CALL BLKDEF(10,MAXCOL,1)
  11292. C
  11293. C  USE HALF PAGE BUFFER FOR NEW ATTRIBUTE VALUE
  11294. C
  11295.       NCOLU = MAXCOL/2
  11296.       CALL BLKDEF(11,NCOLU,1)
  11297. C
  11298. C  SCAN FOR THE WORD FROM OR IN.
  11299. C
  11300.       IFLAG = 0
  11301.       J = LFIND(1,ITEMS,KWIN,2)
  11302.       RNAME = BLANK
  11303.       CALL LXSREC(J+1,1,8,RNAME,1)
  11304.       IF(J.NE.0) GO TO 460
  11305.       J = LFIND(1,ITEMS,KWFROM,4)
  11306.       RNAME = BLANK
  11307.       CALL LXSREC(J+1,1,8,RNAME,1)
  11308.       IF(J.NE.0) GO TO 460
  11309. C
  11310. C  ALL RELATIONS.
  11311. C
  11312.       IFLAG = 1
  11313.       RNAME = BLANK
  11314.   460 CONTINUE
  11315. C
  11316. C  SCAN THROUGH THE ATTRIBUTE TABLE LOOKING FOR THE ATTRIBUTE.
  11317. C
  11318.       NAC = 0
  11319.       NA = 0
  11320.       ANAME = BLANK
  11321.       CALL LXSREC(2,1,8,ANAME,1)
  11322.       I = LOCATT(ANAME,RNAME)
  11323.       IF(I.EQ.0) GO TO 500
  11324.       CALL WARN(3,ANAME,RNAME)
  11325.       GO TO 100
  11326.   500 CONTINUE
  11327.       NA = NA + 1
  11328.       I = LOCATT(ANAME,RNAME)
  11329.       DO 550 I=1,NA
  11330.       CALL ATTGET(ISTAT)
  11331.       IF(ISTAT.NE.0) GO TO 800
  11332.   550 CONTINUE
  11333. C
  11334. C  FIND THE RELATION NAME IN RELATION TABLE.
  11335. C
  11336.       I = LOCREL(RELNAM)
  11337.       IF(I.EQ.0) GO TO 600
  11338. C
  11339. C  UNRECOGNIZED RELATION NAME.
  11340. C
  11341.       CALL WARN(1,RELNAM,0)
  11342.       GO TO 100
  11343.   600 CONTINUE
  11344.       CALL RELGET(ISTAT)
  11345. C
  11346. C  CHECK FOR AUTHORIZATION.
  11347. C
  11348.       L = LOCPRM(RELNAM,2)
  11349.       IF(L.EQ.0) GO TO 700
  11350.       IF(IFLAG.EQ.1) GO TO 500
  11351.       GO TO 4500
  11352.   700 CONTINUE
  11353. C
  11354. C  CALL CHANGE TO FINISH PROCESSING THE COMMAND.
  11355. C
  11356.       KQ1 = BLKLOC(10)
  11357.       KQ11 = BLKLOC(11)
  11358.       CALL RMDATE(RDATE)
  11359.       NAC = NAC + 1
  11360.       CALL CHANGE(BUFFER(KQ1),BUFFER(KQ11))
  11361.       IF(IFLAG.EQ.0) GO TO 100
  11362.       GO TO 500
  11363.   800 CONTINUE
  11364.       IF(NAC.EQ.0) WRITE(NOUT,9001)
  11365.  9001 FORMAT(20H      0 ROWS CHANGED )
  11366.       GO TO 100
  11367. C
  11368. C  *************************
  11369. C  RENAME COMMAND.
  11370. C  *************************
  11371. C
  11372.  1000 CONTINUE
  11373. C
  11374. C  CHECK RENAME SYNTAX
  11375. C
  11376.       IF(EQKEYW(2,KWRELA,8)) GO TO 1100
  11377.       IATT = 2
  11378.       IF(EQKEYW(2,KWATTR,9)) GO TO 1050
  11379.       IATT = 1
  11380.       GO TO 1050
  11381.  1005 CONTINUE
  11382. C
  11383. C  CHANGE THE OWNER.
  11384. C
  11385.       IF(NE(USERID,OWNER)) GO TO 1010
  11386.       IF(ITEMS.NE.4) GO TO 4000
  11387.       IF((LXLENC(4).GE.1).AND.(LXLENC(4).LE.8)) GO TO 1008
  11388.       CALL WARN(7,KWOWNE,BLANK)
  11389.       GO TO 100
  11390.  1008 CONTINUE
  11391.       OWNER = BLANK
  11392.       CALL LXSREC(4,1,8,OWNER,1)
  11393.       GO TO 100
  11394. C
  11395. C  UNABLE TO CHANGE THE OWNER.
  11396. C
  11397.  1010 CONTINUE
  11398.       WRITE(NOUT,9002)
  11399.  9002 FORMAT(41H -ERROR- UNAUTHORIZED TO CHANGE THE OWNER)
  11400.       GO TO 100
  11401.  1050 CONTINUE
  11402. C
  11403. C     RENAME ATTRIBUTE
  11404. C
  11405.       CALL RNAMEA(IATT)
  11406.       GO TO 100
  11407.  1100 CONTINUE
  11408. C
  11409. C     RENAME RELATION
  11410. C
  11411.       CALL RNAMER
  11412.       GO TO 100
  11413. C+  MAKE SURE THAT THE RULES GET CHANGED AS NEEDED
  11414. C
  11415. C  *************************
  11416. C  REMOVE COMMAND.
  11417. C  *************************
  11418. C
  11419.  2000 CONTINUE
  11420.       RNAME = BLANK
  11421.       CALL LXSREC(2,1,8,RNAME,1)
  11422.       IF(ITEMS.NE.2) GO TO 4000
  11423. C
  11424. C  FIND THE RELATION NAME IN THE RELATION TABLE.
  11425. C
  11426.       I = LOCREL(RNAME)
  11427.       IF(I.EQ.0) GO TO 2200
  11428. C
  11429. C  UNRECOGNIZED RELATION NAME.
  11430. C
  11431.       CALL WARN(1,RNAME,0)
  11432.       GO TO 100
  11433.  2200 CONTINUE
  11434. C
  11435. C  CHECK FOR AUTHORIZATION.
  11436. C
  11437.       L = LOCPRM(RNAME,2)
  11438.       IF(L.NE.0) GO TO 4500
  11439. C
  11440. C  CHANGE THE RELATION TABLE.
  11441. C
  11442.       CALL RELGET(ISTAT)
  11443.       CALL RELDEL
  11444. C
  11445. C  CHANGE THE ATTRIBUTE TABLE.
  11446. C
  11447.       I = LOCATT(BLANK,RNAME)
  11448.       IF(I.NE.0) GO TO 100
  11449.  2300 CONTINUE
  11450.       CALL ATTGET(ISTAT)
  11451.       IF(ISTAT.NE.0) GO TO 100
  11452.       CALL ATTDEL(ISTAT)
  11453.       IF(ISTAT.NE.0) GO TO 100
  11454.       GO TO 2300
  11455. C
  11456. C  *************************
  11457. C  DELETE COMMAND.
  11458. C  *************************
  11459. C
  11460.  3000 CONTINUE
  11461.       IF(EQKEYW(2,KWKEY,3)) GO TO 3600
  11462.       IF(EQKEYW(2,KWRULE,4)) GO TO 3900
  11463. C
  11464. C   FIND THE WORD FROM OR IN
  11465. C
  11466.       J = LFIND(1,ITEMS,KWFROM,4)
  11467.       IF(J.NE.0) GO TO 3100
  11468.       J = LFIND(1,ITEMS,KWIN,2)
  11469.       IF(J.EQ.0) GO TO 4000
  11470.  3100 CONTINUE
  11471.       IF(EQKEYW(2,KWTUPL,6)) GO TO 3200
  11472.       IF(EQKEYW(2,KWROWS,4)) GO TO 3200
  11473.       IF(EQKEYW(2,KWDUPL,10)) GO TO 3200
  11474.       GO TO 4000
  11475.  3200 CONTINUE
  11476. C
  11477. C  FIND THE RELATION NAME IN THE RELATION TABLE.
  11478. C
  11479.       RNAME = BLANK
  11480.       CALL LXSREC(J+1,1,8,RNAME,1)
  11481.       I = LOCREL(RNAME)
  11482.       IF(I.EQ.0) GO TO 3300
  11483. C
  11484. C  UNRECOGNIZED RELATION NAME.
  11485. C
  11486.       CALL WARN(1,RNAME,0)
  11487.       GO TO 100
  11488.  3300 CONTINUE
  11489. C
  11490. C  CHECK FOR AUTHORIZATION.
  11491. C
  11492.       L = LOCPRM(RNAME,2)
  11493.       IF(L.NE.0) GO TO 4500
  11494.       IF(EQKEYW(2,KWDUPL,10)) GO TO 3500
  11495. C
  11496. C  CALL DELETE TO FINISH PROCESSING THE COMMAND.
  11497. C
  11498.       CALL BLKDEF(10,MAXCOL,1)
  11499.       KQ1 = BLKLOC(10)
  11500.       CALL DELETE(BUFFER(KQ1))
  11501.       CALL BLKCLR(10)
  11502.       GO TO 100
  11503. C
  11504. C  CALL DELDUP TO DELETE ALL DUPLICATES FROM THE RELATION.
  11505. C
  11506.  3500 CONTINUE
  11507.       CALL BLKDEF(10,MAXCOL,1)
  11508.       KQ1 = BLKLOC(10)
  11509.       CALL DELDUP(BUFFER(KQ1))
  11510.       CALL BLKCLR(10)
  11511.       GO TO 100
  11512. C
  11513. C  REMOVE THE KEY FOR AN ATTRIBUTE.
  11514. C
  11515.  3600 CONTINUE
  11516.       IF(ITEMS.GT.6) GO TO 4000
  11517.       RNAME = BLANK
  11518.       CALL LXSREC(6,1,8,RNAME,1)
  11519.       I = LOCREL(RNAME)
  11520.       IF(I.EQ.0) GO TO 3700
  11521. C
  11522. C  UNRECOGNIZED RELATION NAME.
  11523. C
  11524.       CALL WARN(1,RNAME,0)
  11525.       GO TO 100
  11526.  3700 CONTINUE
  11527. C
  11528. C  CHECK FOR AUTHORIZATION.
  11529. C
  11530.       L = LOCPRM(RNAME,2)
  11531.       IF(L.NE.0) GO TO 4500
  11532.       NAMOLD = BLANK
  11533.       CALL LXSREC(4,1,8,NAMOLD,1)
  11534.       I = LOCATT(NAMOLD,RNAME)
  11535.       IF(I.EQ.0) GO TO 3800
  11536.       CALL WARN(3,NAMOLD,RNAME)
  11537.       GO TO 100
  11538.  3800 CONTINUE
  11539. C
  11540. C  CHANGE THE KEY POINTER TO 0.
  11541. C
  11542.       CALL ATTGET(ISTAT)
  11543.       ATTKEY = 0
  11544.       CALL ATTPUT(ISTAT)
  11545.       GO TO 100
  11546. C
  11547. C  DELETE A RULE.
  11548. C
  11549.  3900 CONTINUE
  11550. C
  11551. C  CHECK FOR PERMISSION
  11552. C
  11553.       IF(EQ(USERID,OWNER)) GO TO 3950
  11554.       WRITE(NOUT,3910)
  11555.  3910 FORMAT(41H -ERROR- UNAUTHORIZED ACCESS TO THE RULES )
  11556.       GO TO 100
  11557. C
  11558. C  GET THE RULE NUMBER AND CALL RULDEL
  11559. C
  11560.  3950 CONTINUE
  11561.       NUMRUL = LXIREC(3)
  11562.       RNAME = K8RRC
  11563.       CALL RULDEL(RNAME,NUMRUL)
  11564.       IF(RMSTAT.EQ.110) GO TO 100
  11565.       RNAME = K8RDT
  11566.       CALL RULDEL(RNAME,NUMRUL)
  11567.       GO TO 100
  11568. C
  11569. C  SYNTAX ERRORS.
  11570. C
  11571.  4000 CONTINUE
  11572.       CALL WARN(4,0,0)
  11573.       GO TO 100
  11574. C
  11575. C  ILLEGAL RELATION ACCESS - WRONG PASSWORD
  11576. C
  11577.  4500 CONTINUE
  11578.       CALL WARN(9,RNAME,0)
  11579.       RMSTAT = 0
  11580.       GO TO 100
  11581. C
  11582. C  FINAL PRINT.
  11583. C
  11584.  5000 CONTINUE
  11585.       CALL BLKCLR(10)
  11586.       CALL BLKCLR(11)
  11587.       RETURN
  11588.       END
  11589.       SUBROUTINE MOTSCN(MOTID,IPTR)
  11590.         Include TEXT.BLK
  11591. C
  11592. C  PURPOSE:  SCAN THROUGH A MULTIPLE OCCURENCE TABLE (MOT)
  11593. C
  11594. C  PARAMETERS
  11595. C    INPUT:  MOTID---ID FOR THIS WORD
  11596. C    OUTPUT: MOTID---ID FOR MOT WORD NEXT TIME OR 0
  11597. C                    (0 IMPLIES THIS IS THE LAST VALUE)
  11598. C            IPTR----USER POINTER DESIRED
  11599. C
  11600. C  DECLARATIVES
  11601.         Include BTBUF.BLK
  11602. C
  11603. C  CHECK FOR END OF MOT LIST.
  11604. C
  11605.   100 CONTINUE
  11606.       IF(MOTID.EQ.0) RETURN
  11607. C
  11608. C  GET THE MOT BLOCK THAT IS NEEDED.
  11609. C
  11610.       CALL ITOH(MOTIND,MOTIDP,MOTID)
  11611.       CALL BTGET(MOTIDP,IN)
  11612.       IND = 3 * IN - 3
  11613.       MOTIND = MOTIND + IND
  11614. C
  11615. C  RETRIEVE THE NEEDED WORD.
  11616. C
  11617.       MOTID = CORE(MOTIND)
  11618.       IPTR = CORE(MOTIND+1)
  11619.       IF(IPTR.EQ.0) GO TO 100
  11620. C
  11621. C  RETURN WITH THE VALUES.
  11622. C
  11623.       RETURN
  11624.       END
  11625.       LOGICAL FUNCTION NE(WORD1,WORD2)
  11626.         Include TEXT.BLK
  11627. C
  11628. C  PURPOSE:   COMPARE WORD1 AND WORD2 FOR NE
  11629. C
  11630. C  PARAMETERS:
  11631. C         WORD1---A WORD OF TEXT
  11632. C         WORD2---ANOTHER WORD OF TEXT
  11633. C         NE------.TRUE. IF WORD1.NE.WORD2
  11634. C                 .FALSE. IF NOT NE
  11635.         Include DCLAR6.BLK
  11636. C
  11637.       NE = WORD1.NE.WORD2
  11638.       RETURN
  11639.       END
  11640.       INTEGER FUNCTION NSCAN(STR1,IC1,LC1,STR2,IC2,LC2)
  11641.         Include TEXT.BLK
  11642. C
  11643. C  PURPOSE:   LOCATE THE FIRST CHARACTER IN STR1 WHICH DOES
  11644. C             NOT MATCH THE CHARACTERS IN STR2
  11645. C
  11646. C  PARAMETERS:
  11647. C     STR1----FIRST HOLLERITH STRING
  11648. C     IC1-----STARTING CHARACTER IN STR1 TO START THE SCAN
  11649. C     LC1-----LENGTH OF STR1
  11650. C     STR2----SECOND HOLLERITH STRING
  11651. C     IC2-----STARTING CHARACTER IN STR2
  11652. C     LC2-----LENGTH OF STR2
  11653. C     NSCAN---CHARACTER POSITION IN STR1 OF FIRST MISMATCH
  11654. C             0 IF ALL MATCH
  11655. C
  11656.       CHARACTER*1 STR1(1)
  11657.       CHARACTER*1 STR2(1)
  11658. C
  11659. C  IF LC1 IS NEGATIVE THE SCAN IS RIGHT TO LEFT.
  11660. C
  11661.       INC = 1
  11662.       IF(LC1.LT.0) INC = -1
  11663.       LC = INC * LC1
  11664.       I1 = IC1
  11665. C
  11666. C  SCAN STR1.
  11667. C
  11668.       DO 200 I=1,LC
  11669.       I2 = IC2 - 1
  11670.       DO 100 J=1,LC2
  11671.       I2 = I2 + 1
  11672.       IF(STR1(I1).NE.STR2(I2)) GO TO 300
  11673.   100 CONTINUE
  11674.       I1 = I1 + INC
  11675.   200 CONTINUE
  11676. C
  11677. C  ALL CHARACTERS MATCH.
  11678. C
  11679.       NSCAN = 0
  11680.       RETURN
  11681. C
  11682. C  WE FOUND A NON-MATCHING CHARACTER.
  11683. C
  11684.   300 CONTINUE
  11685.       NSCAN = I1
  11686.       RETURN
  11687.       END
  11688.       SUBROUTINE PARVAL(ID,MAT,ATYPE,NWORDS,ROW,NCOLT,IERR)
  11689.         Include TEXT.BLK
  11690. C
  11691. C     THIS ROUTINE PARSES A VALUE SPECIFICATION AND STORES THE
  11692. C     VALUE IN MAT.
  11693. C
  11694. C     PARAMETERS.......
  11695. C     ID.......INPUT - STARTING LXLREC ITEM NUMBER
  11696. C              OUTPUT- 1+ITEM NUMBER OF LAST ITEM IN VALUE
  11697. C     MAT......OUTPUT- ARRAY OF VALUES
  11698. C     ATYPE....INPUT - RVEC,IMAT,DOUB STUFF
  11699. C     NWORDS...INPUT - NWORDS PART OF ATTLEN
  11700. C              OUTPUT- ACTUAL NWORDS
  11701. C     ROW......INPUT - OTHER PART OF ATTLEN
  11702. C              OUTPUT- ACTUAL VALUE
  11703. C     IERR.....OUTPUT- ERROR FLAG
  11704. C                      0 MEANS OK
  11705. C                      1 IF TYPE MISMATCH
  11706. C                      2 IF COUNT MISMATCH
  11707. C                      3 IF PAREN MISMATCH
  11708. C
  11709.         Include RMATTS.BLK
  11710.         Include CONST4.BLK
  11711.         Include FILES.BLK
  11712.         Include MISC.BLK
  11713.       INTEGER ATYPE,VECMAT,TYPE,ROW
  11714.       EQUIVALENCE (IR,RR)
  11715.       DIMENSION MAT(1)
  11716.       IF(NCOLT.GT.MAXCOL) GO TO 8300
  11717.       ITEMS = LXITEM(IDUMMY)
  11718.       IERR = 0
  11719.       CALL TYPER(ATYPE,VECMAT,JTYPE)
  11720.       TYPE = JTYPE
  11721.       IF(TYPE.EQ.KZDOUB) TYPE = KZREAL
  11722.       IF(LXWREC(ID,1).EQ.NULL) GO TO 600
  11723.       NWORD = NWORDS
  11724.       IF(JTYPE.EQ.KZDOUB) NWORD = NWORDS/2
  11725.       IF(TYPE.NE.KZTEXT) GO TO 100
  11726. C
  11727. C     TEXT STUFF
  11728. C
  11729.       IF(LXID(ID).NE.KZTEXT) GO TO 8000
  11730.       NW = LXLENW(ID)
  11731.       IF(NWORD.EQ.0) GO TO 50
  11732. C
  11733. C     FIXED TEXT
  11734. C
  11735.       IF(LXLENC(ID).GT.ROW) GO TO 8100
  11736.       NW = NWORD
  11737.       GO TO 80
  11738.    50 CONTINUE
  11739. C
  11740. C     VARIABLE TEXT
  11741. C
  11742.       IF((NCOLT+NW).GT.MAXCOL) GO TO 8300
  11743.       NWORD = NW
  11744.       ROW = LXLENC(ID)
  11745.    80 CONTINUE
  11746.       DO 90 I=1,NW
  11747.       MAT(I) = LXWREC(ID,I)
  11748.    90 CONTINUE
  11749.       ID = ID + 1
  11750.       NWORDS = NWORD
  11751.       RETURN
  11752.   100 CONTINUE
  11753.       NUMI = ITEMS - ID + 1
  11754.       IF(NWORD.GT.NUMI) GO TO 8100
  11755. C
  11756. C     NON-TEXT STUFF
  11757. C
  11758.       IF(LXWREC(ID,1).NE.K4LPAR) GO TO 500
  11759. C
  11760. C     WE HAVE PARENS
  11761. C
  11762.       IF(VECMAT.EQ.KZMAT) GO TO 300
  11763. C
  11764. C     VECTOR
  11765. C
  11766.       IF(NWORD.EQ.0) GO TO 200
  11767. C
  11768. C     FIXED LENGTH VECTOR
  11769. C
  11770.       IF(LXWREC(ID+NWORD+1,1).NE.K4RPAR) GO TO 8100
  11771.       DO 150 I=1,NWORD
  11772.       IF(LXID(ID+I).NE.TYPE) GO TO 8000
  11773.   150 CONTINUE
  11774.       IS = ID + 1
  11775.       NW = NWORD
  11776.       ID = ID + NWORD + 2
  11777.       GO TO 1000
  11778.   200 CONTINUE
  11779. C
  11780. C     VARIABLE
  11781. C
  11782.       L = LFIND(ID,ITEMS-ID+1,K4RPAR,1)
  11783.       IF(L.EQ.0) GO TO 8200
  11784.       NW = L - ID - 1
  11785.       IF((NCOLT+NW).GT.MAXCOL) GO TO 8300
  11786.       NWORD = NW
  11787.       ROW = 1
  11788.       DO 250 I=1,NWORD
  11789.       IF(LXID(ID+I).NE.TYPE) GO TO 8000
  11790.   250 CONTINUE
  11791.       IS = ID + 1
  11792.       ID = L +  1
  11793.       GO TO 1000
  11794.   300 CONTINUE
  11795.       IF(NWORD.EQ.0) GO TO 400
  11796. C
  11797. C     FIXED MATRIX
  11798. C
  11799.       ISKIP = ROW + 2
  11800.       NCOLS = NWORD/ROW
  11801.       IP = ID + 1
  11802.       DO 320 I=1,NCOLS
  11803.       IF(LXWREC(IP,1).NE.K4LPAR) GO TO 8200
  11804.       DO 310 J=1,ROW
  11805.       IF(LXID(IP+J).NE.TYPE) GO TO 8000
  11806.   310 CONTINUE
  11807.       IF(LXWREC(IP+ROW+1,1).NE.K4RPAR) GO TO 8200
  11808.       IP = IP + ISKIP
  11809.   320 CONTINUE
  11810.       IF(LXWREC(IP-1,1).NE.K4RPAR) GO TO 8200
  11811.       IS = ID + 2
  11812.       NW = ISKIP*NCOLS
  11813.       ID = IS + NW
  11814.       GO TO 1000
  11815.   400 CONTINUE
  11816. C
  11817. C     VARIABLE MATRIX - SET NWORD AND ROW THEN USE FIXED CODE
  11818. C
  11819.       L = LFIND(ID,ITEMS-ID+1,K4RPAR,1)
  11820.       IF(L.EQ.0) GO TO 8200
  11821.       IROW = L - ID - 2
  11822.       IF(IROW.LE.0) GO TO 8100
  11823.       IF(ROW.EQ.0) ROW = IROW
  11824.       IF(IROW.NE.ROW) GO TO 8100
  11825.       ISKIP = ROW + 2
  11826.       IS = ID + 1
  11827.       NCOLS = 0
  11828.       DO 420 I=IS,ITEMS,ISKIP
  11829.       IF(LXWREC(I,1).EQ.K4RPAR) GO TO 450
  11830.       NCOLS = NCOLS + 1
  11831.   420 CONTINUE
  11832.       GO TO 8200
  11833.   450 CONTINUE
  11834.       NWX = ROW*NCOLS
  11835.       IF(JTYPE.EQ.KZDOUB) NWX = 2*NWX
  11836.       IF((NCOLT+NWX).GT.MAXCOL) GO TO 8300
  11837.       NWORD = ROW*NCOLS
  11838.       GO TO 300
  11839.   500 CONTINUE
  11840. C
  11841. C     NO PARENS
  11842. C
  11843.       IF(NWORD.EQ.0) GO TO 8200
  11844.       DO 550 I=1,NWORD
  11845.       IF(LXID(ID+I-1).NE.TYPE) GO TO 8000
  11846.   550 CONTINUE
  11847.       IS = ID
  11848.       NW = NWORD
  11849.       ID = ID + NWORD
  11850.       GO TO 1000
  11851.   600 CONTINUE
  11852. C
  11853. C     NULL VALUES
  11854. C
  11855.       ID = ID + 1
  11856.       IF(NWORDS .EQ.0) GO TO 650
  11857. C
  11858. C     FIXED NULL
  11859. C
  11860.       NW = NWORDS
  11861.       DO 620 I=1,NW
  11862.       MAT(I) = IBLANK
  11863.   620 CONTINUE
  11864.       MAT(1) = NULL
  11865.       GO TO 9999
  11866.   650 CONTINUE
  11867. C
  11868. C VARIABLE NULL
  11869. C
  11870.       IF((NCOLT+1).GT.MAXCOL) GO TO 8300
  11871.       MAT(1) = NULL
  11872.       NWORDS = 1
  11873.       ROW = 1
  11874.       IF(ATYPE.EQ.KZTEXT) ROW = 3
  11875.       IF(JTYPE.NE.KZDOUB) GO TO 9999
  11876.       IF((NCOLT+2).GT.MAXCOL) GO TO 8300
  11877.       NWORDS = 2
  11878.       MAT(2) = IBLANK
  11879.       GO TO 9999
  11880.  1000 CONTINUE
  11881. C
  11882. C     DUMP STUFF INTO MAT
  11883. C
  11884.       NW = NW + IS - 1
  11885.       MATIN = 1
  11886.       IF(JTYPE.EQ.KZDOUB) GO TO 1200
  11887.       IF(TYPE.EQ.KZINT) GO TO 1100
  11888. C
  11889. C     REAL AND SINGLE WORD DOUBLE
  11890. C
  11891.       DO 1050 I=IS,NW
  11892.       IF(LXID(I).EQ.KZTEXT) GO TO 1050
  11893.       RR = RXREC(I)
  11894.       MAT(MATIN) = IR
  11895.       MATIN = MATIN + 1
  11896.  1050 CONTINUE
  11897.       GO TO 9990
  11898.  1100 CONTINUE
  11899. C
  11900. C     INTEGER
  11901. C
  11902.       DO 1150 I=IS,NW
  11903.       IF(LXID(I).EQ.KZTEXT) GO TO 1150
  11904.       MAT(MATIN) = LXIREC(I)
  11905.       MATIN = MATIN + 1
  11906.  1150 CONTINUE
  11907.       GO TO 9990
  11908.  1200 CONTINUE
  11909. C
  11910. C     TWO WORD DOUBLE
  11911. C
  11912.       DO 1250 I=IS,NW
  11913.       IF(LXID(I).EQ.KZTEXT) GO TO 1250
  11914.       RR = RXREC(I)
  11915.       MAT(MATIN) = IR
  11916.       MAT(MATIN+1) = 0
  11917.       MATIN = MATIN + 2
  11918.  1250 CONTINUE
  11919.       GO TO 9990
  11920.  8000 CONTINUE
  11921.       WRITE (NOUT,8010) ID
  11922.  8010 FORMAT(50H -ERROR- TYPE MISMATCH FOR VALUE STARTING AT ITEM ,I3)
  11923.       IERR = 1
  11924.       GO TO 9999
  11925.  8100 CONTINUE
  11926.       WRITE (NOUT,8110)ID
  11927.  8110 FORMAT(
  11928.      X 53H -ERROR- INCORRECT LENGTH FOR VALUE STARTING AT ITEM ,I3)
  11929.       IERR = 2
  11930.       GO TO 9999
  11931.  8200 CONTINUE
  11932.       WRITE (NOUT,8210) ID
  11933.  8210 FORMAT(
  11934.      X 51H -ERROR- PAREN MISMATCH FOR VALUE STARTING AT ITEM ,I3)
  11935.       IERR = 3
  11936.       GO TO 9999
  11937.  8300 CONTINUE
  11938.       WRITE(NOUT,8310) MAXCOL
  11939.  8310 FORMAT(36H -ERROR- RELATION ROW LENGTH EXCEEDS,I5)
  11940.       IERR = 2
  11941.       GO TO 9999
  11942.  9990 CONTINUE
  11943. C
  11944. C     RESET NWORDS
  11945. C
  11946.       NWORDS = NWORD
  11947.       IF(JTYPE.EQ.KZDOUB) NWORDS = 2*NWORD
  11948.  9999 CONTINUE
  11949.       RETURN
  11950.       END
  11951.       SUBROUTINE PJECT
  11952.         Include TEXT.BLK
  11953. C
  11954. C  THIS ROUTINE PERFORMS PHYSICAL PROJECTIONS ON EXISTING RELATIONS.
  11955. C  THE SYNTAX OF THE PROJECT COMMAND IS :
  11956. C
  11957. C     PROJECT RNAME2 FROM RNAME1 USING ATTR1 ATTR2...ATTRN
  11958. C     -------        ----        -----
  11959. C
  11960. C
  11961. C     INPUTS :
  11962. C        LODREC(1) = 'PROJECT'
  11963. C        LODREC(2) = NEW RELATION NAME
  11964. C        LODREC(3) = 'FROM'
  11965. C        LODREC(4) = OLD RELATION NAME
  11966. C        LODREC(5) = 'USING'
  11967. C        LODREC(6) = ATTRIBUTE 1
  11968. C        LODREC(7) = ATTRIBUTE 2
  11969. C           .             .
  11970. C           .             .
  11971. C        LODREC(N) = ATTRIBUTE N-5
  11972. C
  11973. C
  11974. C     OUTPUTS :
  11975. C        NEW RELATION TABLES AND DATA TABLES FOR RNAME2
  11976. C
  11977. C
  11978. C
  11979.         Include RIMPTR.BLK
  11980.         Include RMKEYW.BLK
  11981.  
  11982.         Include WHCOM.BLK
  11983.         Include TUPLER.BLK
  11984.         Include TUPLEA.BLK
  11985.         Include FILES.BLK
  11986.         Include BUFFER.BLK
  11987.         Include MISC.BLK
  11988.         Include RIMCOM.BLK
  11989.         Include FLAGS.BLK
  11990. C
  11991. C
  11992.       INTEGER STATUS
  11993.       LOGICAL EQKEYW
  11994.       INTEGER ATNCOL
  11995.         Include DCLAR1.BLK
  11996. C
  11997. C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
  11998. C
  11999.       CALL RMDBLK(DBNAME)
  12000.       IF(RMSTAT.EQ.0) GO TO 1000
  12001.       CALL WARN(RMSTAT,DBNAME,0)
  12002.       GO TO 9999
  12003. C
  12004. C  KEYWORD SYNTAX IS OKAY - NOW CHECK RELATION NAMES
  12005. C
  12006.  1000 CONTINUE
  12007.       CALL BLKCLN
  12008.       IF(.NOT.EQKEYW(3,KWFROM,4)) GO TO 9900
  12009.       IF(.NOT.EQKEYW(5,KWUSIN,5)) GO TO 9900
  12010.       RNAME1 = BLANK
  12011.       CALL LXSREC(4,1,8,RNAME1,1)
  12012.       I = LOCREL(RNAME1)
  12013.       LENF = NCOL
  12014.       IF(I.EQ.0) GO TO 1100
  12015. C
  12016. C  RNAME1 DOES NOT EXIST
  12017. C
  12018.       CALL WARN(1,RNAME1,0)
  12019.       GO TO 9999
  12020. C
  12021. C
  12022.  1100 CONTINUE
  12023.       IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.8)) GO TO 1200
  12024.       CALL WARN(7,KWRELA,BLANK)
  12025.       GO TO 9999
  12026.  1200 CONTINUE
  12027.       RNAME2 = BLANK
  12028.       CALL LXSREC(2,1,8,RNAME2,1)
  12029.       I = LOCREL(RNAME2)
  12030.       IF(I.NE.0) GO TO 1400
  12031. C
  12032. C  DUPLICATE RELATION NAME ENCOUNTERED
  12033. C
  12034.       WRITE (NOUT,1220)
  12035.  1220 FORMAT(
  12036.      X 55H -ERROR- RESULTANT RELATION DOES NOT HAVE A UNIQUE NAME )
  12037.       GO TO 9999
  12038. C
  12039. C  CHECK USER READ SECURITY
  12040. C
  12041.  1400 CONTINUE
  12042.       I = LOCREL(RNAME1)
  12043.       I = LOCPRM(RNAME1,1)
  12044.       IF(I.EQ.0) GO TO 1410
  12045.       CALL WARN(9,RNAME1,0)
  12046.       GO TO 9999
  12047.  1410 CONTINUE
  12048.       NS = 0
  12049.       NID = RSTART
  12050. C
  12051. C  SET UP THE WHERE CLAUSE
  12052. C
  12053.       ITEMS = LXITEM(NUM)
  12054.       K = LFIND(1,ITEMS,KWWHER,5)
  12055.       NBOO = 0
  12056.       LIMTU = ALL9S
  12057.       RMSTAT = 0
  12058.       KKX = K
  12059.       IF(K.NE.0) CALL WHERE(KKX)
  12060.       IF(RMSTAT.NE.0) GO TO 9999
  12061. C
  12062. C  CHECK THE ATTRIBUTES AND BUILD POINTER ARRAY - POS. 10
  12063. C
  12064.       NOATTS = 0
  12065.       CALL BLKDEF(10,LENF,1)
  12066.       KQ10 = BLKLOC(10) - 1
  12067.       NOCOLS = 0
  12068.       II = ITEMS
  12069.       IF(K.NE.0) II = K - 1
  12070.       IFALL = 0
  12071.       IF(II.NE.6) GO TO 1450
  12072.       IF(.NOT.EQKEYW(6,KWALL,3)) GO TO 1450
  12073. C
  12074. C     ALL
  12075. C
  12076.       II = NATT + 5
  12077.       IFALL = 1
  12078.       GO TO 1470
  12079.  1450 CONTINUE
  12080. C
  12081. C  CHECK THAT ALL ATTRIBUTES ARE LEGAL
  12082. C
  12083.       IERR = 0
  12084.       DO 1460 I=6,II
  12085.       ANAME = BLANK
  12086.       CALL LXSREC(I,1,8,ANAME,1)
  12087.       IF(LOCATT(ANAME,NAME).EQ.0) GO TO 1460
  12088.       CALL WARN(3,ANAME,NAME)
  12089.       IERR = 1
  12090.  1460 CONTINUE
  12091.       IF(IERR.EQ.1) GO TO 9999
  12092.  1470 CONTINUE
  12093.       CALL ATTNEW(RNAME2,II-5)
  12094.       DO 1600 I=6,II
  12095.       IF(IFALL.EQ.0) GO TO 1490
  12096.       NUM = I - 5
  12097.       STATUS = LOCATT(BLANK,NAME)
  12098.       DO 1480 J=1,NUM
  12099.       CALL ATTGET(STATUS)
  12100.       IF(STATUS.NE.0) GO TO 1600
  12101.  1480 CONTINUE
  12102.       GO TO 1500
  12103.  1490 CONTINUE
  12104.       ANAME = BLANK
  12105.       CALL LXSREC(I,1,8,ANAME,1)
  12106.       IERR = LOCATT(ANAME,NAME)
  12107.  1500 CONTINUE
  12108.       IF(IFALL.EQ.0) CALL ATTGET(STATUS)
  12109.       NOATTS = NOATTS + 1
  12110.       ATNCOL = NOCOLS + 1
  12111.       IF(ATTWDS.LE.0) GO TO 1540
  12112. C
  12113. C     FIXED LENGTH
  12114. C
  12115.       KQ = KQ10 + ATTCOL
  12116.       DO 1520 KK=1,ATTWDS
  12117.       NOCOLS = NOCOLS + 1
  12118.       BUFFER(KQ) = NOCOLS
  12119.       KQ = KQ + 1
  12120.  1520 CONTINUE
  12121.       GO TO 1560
  12122.  1540 CONTINUE
  12123. C
  12124. C     VARIABLE LENGTH
  12125. C
  12126.       NOCOLS = NOCOLS + 1
  12127.       BUFFER(KQ10+ATTCOL) = -NOCOLS
  12128.  1560 CONTINUE
  12129.       RELNAM = RNAME2
  12130.       ATTCOL = ATNCOL
  12131.       ATTKEY = 0
  12132.       CALL ATTADD
  12133.  1600 CONTINUE
  12134. C
  12135. C  SET UP RELTBLE
  12136. C
  12137.       NAME = RNAME2
  12138.       CALL RMDATE(RDATE)
  12139.       NCOL = NOCOLS
  12140.       NATT = NOATTS
  12141.       NTUPLE = 0
  12142.       RSTART = 0
  12143.       REND = 0
  12144.       CALL RELADD
  12145. C
  12146. C     1 IS INPUT BUFFER, 2 IS OUTPUT BUFFER, 11 IS OUTPUT TUPLE
  12147. C
  12148.       LPAG = MAXCOL + 2
  12149.       CALL BLKDEF(11,LPAG,1)
  12150.       KQ11 = BLKLOC(11)
  12151. C
  12152. C     LOOP THRU THOSE TUPLES
  12153. C
  12154.       RMSTAT = 0
  12155.       I = LOCREL(RNAME1)
  12156.       KNEW = 0
  12157.       MSTART = 0
  12158.       MEND = 0
  12159.  1700 CONTINUE
  12160.       CALL RMLOOK(IPOINT,1,1,LENGTH)
  12161.       IF(RMSTAT.NE.0) GO TO 1800
  12162.       CALL PRJTUP(BUFFER(KQ10+1),LENF,NOCOLS,BUFFER(IPOINT),
  12163.      X            BUFFER(KQ11),LENT)
  12164.       CALL ADDDAT(2,MEND,BUFFER(KQ11),LENT)
  12165.       IF(MSTART.EQ.0)MSTART = MEND
  12166.       KNEW = KNEW + 1
  12167.       GO TO 1700
  12168.  1800 CONTINUE
  12169.       I = LOCREL(RNAME2)
  12170.       CALL RELGET(STATUS)
  12171.       NTUPLE = KNEW
  12172.       RSTART = MSTART
  12173.       REND = MEND
  12174.       CALL RELPUT
  12175.       WRITE (NOUT,2180) KNEW
  12176.  2180 FORMAT(30H SUCCESSFUL PROJECT OPERATION ,I5,
  12177.      X       15H ROWS GENERATED  )
  12178.       GO TO 9999
  12179. C
  12180. C
  12181.  9900 CONTINUE
  12182.       CALL WARN(4,0,0)
  12183. C
  12184.  9999 CONTINUE
  12185.       CALL BLKCLR(10)
  12186.       CALL BLKCLR(11)
  12187.       RETURN
  12188.       END
  12189.       SUBROUTINE PRJTUP(POINTS,LENP,LENNEW,OLDTUP,NEWTUP,LENT)
  12190.         Include TEXT.BLK
  12191. C
  12192. C     THIS ROUTINE BUILDS A NEW TUPLE FROM AN OLD TUPLE USING
  12193. C     POINTS AS A GUIDING ARRAY.
  12194. C
  12195. C   INPUT
  12196. C     POINTS  - ARRAY THE LENGTH OF THE FIXED PORTION OF OLDREL.
  12197. C               EACH WORD CONTAINS A ZERO OR THE RECIEVING ADDRESS
  12198. C               IN NEW TUPLE (ZERO MEANS NOT IN NEW TUPLE)
  12199. C               IF ATTRIBUTE IS VARIABLE ADDRESS IS STORED AS NEGATIVE
  12200. C     LENP    - LENGTH OF POINTS
  12201. C     LENNEW  - LENGTH OF FIXED PORTION OF NEW TUPLE
  12202. C     OLDTUP  - OLD TUPLE
  12203. C   OUTPUT
  12204. C     NEWTUP  - NEW TUPLE
  12205. C     LENT    - LENGTH OF NEW TUPLE
  12206. C
  12207.       INTEGER POINTS(LENP),OLDTUP(LENP),NEWTUP(LENP)
  12208.       LENT = LENNEW
  12209.       DO 100 I=1,LENP
  12210.       IF(POINTS(I).EQ.0) GO TO 100
  12211.       IF(POINTS(I).GT.0) GO TO 50
  12212. C
  12213. C     VARIABLE ATTRIBUTE
  12214. C
  12215.       IADD = OLDTUP(I)
  12216.       NOCOLS = -POINTS(I)
  12217.       NEWTUP(NOCOLS) = LENT + 1
  12218.       LEN = OLDTUP(IADD) + 2
  12219.       DO 40 K=1,LEN
  12220.       LENT = LENT + 1
  12221.       NEWTUP(LENT) = OLDTUP(IADD)
  12222.       IADD = IADD + 1
  12223.    40 CONTINUE
  12224.       GO TO 100
  12225.    50 CONTINUE
  12226. C
  12227. C     FIXED ATTRIBUTE
  12228. C
  12229.       NUM = POINTS(I)
  12230.       NEWTUP(NUM) = OLDTUP(I)
  12231.   100 CONTINUE
  12232.       RETURN
  12233.       END
  12234.       SUBROUTINE PRULE(NUMRUL)
  12235.         Include TEXT.BLK
  12236. C
  12237. C  THIS ROUTINE DUMPS OUT RULES ASSOCIATED WITH A RIM DATABASE
  12238. C
  12239. C  PARAMETERS:
  12240. C     NUMRUL--NUMBER OF THE RULE TO PRINT
  12241. C
  12242.         Include CONST4.BLK
  12243.         Include RMKEYW.BLK
  12244.         Include CONST8.BLK
  12245.         Include FILES.BLK
  12246.         Include TUPLER.BLK
  12247.         Include TUPLEA.BLK
  12248.         Include WHCOM.BLK
  12249.         Include RIMPTR.BLK
  12250.         Include RIMCOM.BLK
  12251.         Include MISC.BLK
  12252.         Include RELTBL.BLK
  12253. C
  12254.       DIMENSION MAT(24)
  12255.       DIMENSION LINE(18)
  12256.       INTEGER SAVSCR(21)
  12257.       INTEGER SAVTUR(13)
  12258.       INTEGER ANDOR
  12259.       LOGICAL EQ
  12260. C
  12261. C  PRINT HEADING.
  12262. C
  12263.       WRITE(NOUTR,9000) NUMRUL
  12264.  9000 FORMAT(13H RULE NUMBER ,I5)
  12265. C
  12266. C  PROCESS THIS RULE.
  12267. C
  12268.       MWDS = 5 + ((8-1)/CHPWD + 1)*4
  12269.       CALL BLKMOV(SAVTUR,NAME,MWDS)
  12270.       CALL BLKMOV(SAVSCR,IVAL,6)
  12271.       SAVSCR(7) = NBOO
  12272.       SAVSCR(8) = BOO(1)
  12273.       SAVSCR(9) = KATTP(1)
  12274.       SAVSCR(10) = KATTL(1)
  12275.       SAVSCR(11) = KATTY(1)
  12276.       SAVSCR(12) = KOMTYP(1)
  12277.       SAVSCR(13) = KOMPOS(1)
  12278.       SAVSCR(14) = KOMLEN(1)
  12279.       SAVSCR(15) = KOMPOT(1)
  12280.       SAVSCR(16) = KSTRT
  12281.       SAVSCR(17) = MAXTU
  12282.       SAVSCR(18) = LIMTU
  12283.       SAVSCR(19) = WHRVAL(1)
  12284.       SAVSCR(20) = WHRVAL(2)
  12285.       SAVSCR(21) = WHRLEN(1)
  12286. C
  12287. C  PREPARE TO CALL RMLOOK.
  12288. C
  12289.       I = LOCREL(K8RDT)
  12290.       IF(I.NE.0) GO TO 9999
  12291. C
  12292. C  SET UP A WHERE CLAUSE FOR THE ATTRIBUTE VALUE
  12293. C
  12294.       RMSTAT = 0
  12295.       NBOO = 0
  12296.       I = LOCATT(K8NUM,K8RDT)
  12297.       IF(I.NE.0) GO TO 9999
  12298.       CALL ATTGET(I)
  12299.       IF(I.NE.0) GO TO 9999
  12300.       NBOO = 1
  12301.       BOO(1) = K4AND
  12302.       KATTP(1) = ATTCOL
  12303.       KATTL(1) = ATTLEN
  12304.       KATTY(1) = ATTYPE
  12305.       KOMTYP(1) = 2
  12306.       KOMPOS(1) = 1
  12307.       KOMLEN(1) = 1
  12308.       KOMPOT(1) = 1
  12309.       WHRVAL(1) = NUMRUL
  12310.       WHRLEN(1) = 1
  12311.       KSTRT = 0
  12312.       MAXTU = ALL9S
  12313.       LIMTU = ALL9S
  12314.       CALL RMLOOK(MAT,2,0,LEN)
  12315.   100 CONTINUE
  12316.       IF(RMSTAT.NE.0) GO TO 9999
  12317. C
  12318. C  BLANK FILL THE LINE.
  12319. C
  12320.       CALL FILCH(LINE,1,72,BLANK)
  12321.       CALL STRMOV(MAT(4),1,8,LINE,2)
  12322.       IF(EQ(MAT(6),BLANK)) GO TO 300
  12323. C
  12324. C  THERE IS AN 'IN' CLAUSE.
  12325. C
  12326.       CALL STRMOV(BLANK,1,4,LINE,10)
  12327.       CALL STRMOV(KWIN,1,2,LINE,11)
  12328.       CALL STRMOV(MAT(6),1,8,LINE,14)
  12329.       GO TO 400
  12330. C
  12331. C  NO 'IN' CLAUSE.
  12332. C
  12333.   300 CONTINUE
  12334.       CALL STRMOV(BLANK,1,4,LINE,10)
  12335.       CALL STRMOV(BLANK,1,8,LINE,14)
  12336. C
  12337. C  IS RELNAME2 BLANK ?
  12338. C
  12339.   400 CONTINUE
  12340.       CALL STRMOV(BLANK,1,5,LINE,22)
  12341.       CALL STRMOV(MAT(8),1,3,LINE,23)
  12342.       CALL ITOH(NCHAR,ITYPE,MAT(10))
  12343.       IF(ITYPE.NE.3) GO TO 500
  12344. C
  12345. C  OBJECT IS AN ATTRIBUTE.
  12346. C
  12347.       CALL STRMOV(MAT(11),1,8,LINE,27)
  12348.       CALL STRMOV(BLANK,1,4,LINE,35)
  12349.       CALL STRMOV(KWIN,1,2,LINE,36)
  12350.       CALL STRMOV(MAT(13),1,8,LINE,39)
  12351.       GO TO 700
  12352. C
  12353. C  OBJECT IS A VALUE .
  12354. C
  12355.   500 CONTINUE
  12356.       IF(ITYPE.EQ.0) CALL STRMOV(MAT(15),1,NCHAR,LINE,27)
  12357.       IF(ITYPE.EQ.1) CALL ITOC(LINE,27,10,MAT(15),IERR)
  12358.       IF(ITYPE.EQ.2) CALL RTOC(LINE,27,10,MAT(15))
  12359. C
  12360.   700 CONTINUE
  12361.       CALL STRMOV(BLANK,1,4,ANDOR,1)
  12362.       CALL RMLOOK(MAT,2,0,LEN)
  12363.       IF(RMSTAT.EQ.0) ANDOR = MAT(2)
  12364. C
  12365. C  WRITE OUT THE ACTUAL RULE.
  12366. C
  12367.       LEN = 38
  12368.       IF(ITYPE.EQ.0) LEN = 68
  12369.       IF(ITYPE.EQ.3) LEN = 50
  12370.       CALL STRMOV(ANDOR,1,3,LINE,LEN)
  12371.       CALL SPOUT(LINE,70)
  12372.       GO TO 100
  12373. C
  12374. C  RESTORE THE POINTERS AND RETURN
  12375. C
  12376.  9999 CONTINUE
  12377.       CALL BLKMOV(NAME,SAVTUR,MWDS)
  12378.       I = LOCREL(NAME)
  12379.       LRROW = LRROW + 1
  12380.       CALL BLKMOV(IVAL,SAVSCR,6)
  12381.       NBOO = SAVSCR(7)
  12382.       BOO(1) = SAVSCR(8)
  12383.       KATTP(1) = SAVSCR(9)
  12384.       KATTL(1) = SAVSCR(10)
  12385.       KATTY(1) = SAVSCR(11)
  12386.       KOMTYP(1) = SAVSCR(12)
  12387.       KOMPOS(1) = SAVSCR(13)
  12388.       KOMLEN(1) = SAVSCR(14)
  12389.       KOMPOT(1) = SAVSCR(15)
  12390.       KSTRT = SAVSCR(16)
  12391.       MAXTU = SAVSCR(17)
  12392.       LIMTU = SAVSCR(18)
  12393.       WHRVAL(1) = SAVSCR(19)
  12394.       WHRVAL(2) = SAVSCR(20)
  12395.       WHRLEN(1) = SAVSCR(21)
  12396.       RETURN
  12397.       END
  12398.       SUBROUTINE PTRS(IP1,IP2,K,NATT3,PTABLE,LEN,ITYPE)
  12399.         Include TEXT.BLK
  12400. C
  12401. C  THIS ROUTINE LOCATES THE PAIRS OF POINTERS TO COMMON
  12402. C  ATTRIBUTES FOR A SUBTRACT OR INTERSECT
  12403. C
  12404.       INTEGER PTABLE(7,*)
  12405. C
  12406.       IF(K.GT.NATT3) GO TO 500
  12407. C
  12408.   100 CONTINUE
  12409.       I = K
  12410.       IF(PTABLE(3,I).EQ.0) GO TO 200
  12411.       IF(PTABLE(4,I).EQ.0) GO TO 200
  12412.       IP1 = PTABLE(3,I)
  12413.       IP2 = PTABLE(4,I)
  12414.       CALL ITOH(IDUM,LEN,PTABLE(6,I))
  12415.       ITYPE = PTABLE(7,I)
  12416.       K = K + 1
  12417.       GO TO 9999
  12418.   200 CONTINUE
  12419.       K = K + 1
  12420.       IF(K.GT.NATT3) GO TO 500
  12421.       GO TO 100
  12422.   500 CONTINUE
  12423. C
  12424. C  DONE GOING THROUGH THE POINTERS.
  12425. C
  12426.       K = 0
  12427.       LEN = 0
  12428.  9999 RETURN
  12429.       END
  12430.       SUBROUTINE PUTDAT(INDEX,ID,ARRAY,LENGTH)
  12431.         Include TEXT.BLK
  12432. C
  12433. C  PURPOSE:   REPLACE A TUPLE ON THE DATA FILE
  12434. C
  12435. C  PARAMETERS:
  12436. C         INDEX---BLOCK REFERENCE NUMBER
  12437. C         ID------PACKED ID WORD WITH OFFSET,IOBN
  12438. C         ARRAY---ARRAY TO RECEIVE THE TUPLE
  12439. C         LENGTH--LENGTH OF THE TUPLE
  12440.         Include F2COM.BLK
  12441.         Include RIMCOM.BLK
  12442.         Include BUFFER.BLK
  12443.         Include FLAGS.BLK
  12444. C
  12445.       INTEGER OFFSET
  12446.       INTEGER ARRAY(1)
  12447. C
  12448. C  UNPAC THE ID WORD.
  12449. C
  12450.       CALL ITOH(OFFSET,IOBN,ID)
  12451. C
  12452. C  SEE IF THE NEEDED BLOCK IS CURRENTLY IN CORE.
  12453. C
  12454.       NUMBLK = 0
  12455.       DO 200 I=1,3
  12456.       IF(IOBN.EQ.CURBLK(I)) NUMBLK = I
  12457.   200 CONTINUE
  12458.       IF(NUMBLK.NE.0) GO TO 400
  12459.       NUMBLK = INDEX
  12460. C
  12461. C  WE MUST DO PAGING.
  12462. C
  12463. C  SEE IF THE CURRENT BLOCK NEEDS WRITING.
  12464. C
  12465.       IF(MODFLG(NUMBLK).EQ.0) GO TO 300
  12466. C
  12467. C  WRITE OUT THE CURRENT BLOCK.
  12468. C
  12469.       KQ1 = BLKLOC(NUMBLK)
  12470.       CALL RIOOUT(FILE2,CURBLK(NUMBLK),BUFFER(KQ1),LENBF2,IOS)
  12471.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  12472.   300 CONTINUE
  12473. C
  12474. C  READ IN THE NEEDED BLOCK.
  12475. C
  12476.       CALL BLKCHG(NUMBLK,LENBF2,1)
  12477.       KQ1 = BLKLOC(NUMBLK)
  12478.       CALL RIOIN(FILE2,IOBN,BUFFER(KQ1),LENBF2,IOS)
  12479.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  12480.       CURBLK(NUMBLK) = IOBN
  12481.   400 CONTINUE
  12482.       MODFLG(NUMBLK) = 1
  12483.       IFMOD = .TRUE.
  12484. C
  12485. C  MOVE THE TUPLE TO THE PAGE.
  12486. C
  12487.       KQ0 = BLKLOC(NUMBLK) - 1
  12488.       LEN = BUFFER(KQ0 + OFFSET + 1)
  12489.       IF(LEN.NE.LENGTH) RMSTAT = 1002
  12490.       CALL BLKMOV(BUFFER(KQ0 + OFFSET + 2),ARRAY(1),LEN)
  12491. C
  12492. C  ALL DONE.
  12493. C
  12494.       RETURN
  12495.       END
  12496.       SUBROUTINE PUTT(STR1,IC1,WORD)
  12497.         Include TEXT.BLK
  12498. C
  12499. C  PURPOSE:   PUT THE FIRST CHARACTER OF WORD IN STR1 AT IC1
  12500. C
  12501. C  PARAMETERS:
  12502. C     STR1----STRING OF CHARACTERS
  12503. C     IC1-----THE CHARACTER WANTED
  12504. C     WORD----WORD WITH THE CHARACTER (LEFT JUSTIFIED, BLANK FILL)
  12505. C
  12506.       CHARACTER*1 STR1(1)
  12507.       CHARACTER*1 WORD(1)
  12508.       STR1(IC1) = WORD(1)
  12509.       RETURN
  12510.       END
  12511.       SUBROUTINE QUERY
  12512.         Include TEXT.BLK
  12513. C
  12514. C  THIS ROUTINE IS THE DRIVER FOR QUERY OF THE RIM DATA BASE.
  12515. C
  12516.         Include RMATTS.BLK
  12517.         Include RMKEYW.BLK
  12518.         Include CONST4.BLK
  12519.         Include CONST8.BLK
  12520.         Include RIMCOM.BLK
  12521.         Include RIMPTR.BLK
  12522.         Include WHCOM.BLK
  12523.         Include TUPLEA.BLK
  12524.         Include TUPLER.BLK
  12525.         Include FLAGS.BLK
  12526.         Include FILES.BLK
  12527.         Include MISC.BLK
  12528.         Include SRTCOM.BLK
  12529.       LOGICAL EQKEYW
  12530.       LOGICAL SAORD
  12531.         Include DCLAR1.BLK
  12532. C
  12533. C  READ A CARD
  12534. C
  12535.       NEXTOP = K8READ
  12536.       GO TO 200
  12537.   100 CONTINUE
  12538.       CALL LODREC
  12539. C
  12540. C  SCAN A COMMAND.
  12541. C
  12542.   200 CONTINUE
  12543.       ITEMS = LXITEM(IDUMMY)
  12544.       NS = 0
  12545.       IF(EQKEYW(1,KWSELE,6)) GO TO 400
  12546.       IF(EQKEYW(1,KWTALL,5)) GO TO 400
  12547.       IF(EQKEYW(1,KWCOMP,7)) GO TO 400
  12548.       IF(EQKEYW(1,KWNEWP,7)) GO TO 1600
  12549. C
  12550. C  UNRECOGNIZED COMMAND.
  12551. C
  12552.       NEXTOP = K8USE
  12553.       GO TO 2000
  12554. C
  12555. C  ERROR IN COMMAND.
  12556. C
  12557.   350 CONTINUE
  12558.       CALL WARN(4,0,0)
  12559.       GO TO 100
  12560. C
  12561. C  PRINT COMMAND.
  12562. C
  12563.   400 CONTINUE
  12564. C
  12565. C  SCAN FOR THE WORD FROM.
  12566. C
  12567.       J = LFIND(1,ITEMS,KWFROM,4)
  12568.       IF(J.EQ.0) GO TO 350
  12569.       IF(EQKEYW(1,KWSELE,6)) GO TO 410
  12570.       IF(EQKEYW(1,KWTALL,5)) GO TO 440
  12571.       IF(EQKEYW(1,KWCOMP,7)) GO TO 470
  12572. C
  12573. C  CHECK SELECT SYNTAX
  12574. C
  12575.   410 CONTINUE
  12576.       IF(J.LT.3) GO TO 350
  12577.       IF((EQKEYW(2,KWALL,3)).AND.(J.NE.3)) GO TO 350
  12578.       IF(J.EQ.ITEMS) GO TO 350
  12579.       JS = LFIND(1,ITEMS,KWSORT,6)
  12580.       JW = LFIND(1,ITEMS,KWWHER,5)
  12581.       IF(JS.EQ.0) GO TO 420
  12582.       IF((JS+1).GE.ITEMS) GO TO 350
  12583.       IF((JS-J).NE.2) GO TO 350
  12584.       IF(.NOT.EQKEYW(JS+1,KWBY,2)) GO TO 350
  12585.       IF(JW.EQ.0) GO TO 499
  12586.       IF((JW-JS).LT.3) GO TO 350
  12587.       GO TO 499
  12588.   420 IF(JW.EQ.0) GO TO 430
  12589.       IF((JW-J).NE.2) GO TO 350
  12590.       GO TO 499
  12591.   430 IF((J+1).NE.ITEMS) GO TO 350
  12592.       GO TO 499
  12593. C
  12594. C  CHECK TALLY SYNTAX
  12595. C
  12596.   440 CONTINUE
  12597.       IF((J.NE.3).AND.(J.NE.5)) GO TO 350
  12598.   450 JW = LFIND(1,ITEMS,KWWHER,5)
  12599.       IF(JW.NE.0) GO TO 460
  12600.       IF((J+1).NE.ITEMS) GO TO 350
  12601.       GO TO 499
  12602.   460 IF((JW-J).NE.2) GO TO 350
  12603.       GO TO 499
  12604. C
  12605. C  CHECK COMPUTE SYNTAX
  12606. C
  12607.   470 CONTINUE
  12608.       IF(J.NE.4) GO TO 350
  12609.       GO TO 450
  12610.   499 CONTINUE
  12611.       RNAME = BLANK
  12612.       CALL LXSREC(J+1,1,8,RNAME,1)
  12613. C
  12614. C  FIND THE RELATION NAME IN RELTBLE.
  12615. C
  12616.       I = LOCREL(RNAME)
  12617.       IF(I.EQ.0) GO TO 500
  12618. C
  12619. C  UNRECOGNIZED RELATION NAME.
  12620. C
  12621.       CALL WARN(1,RNAME,0)
  12622.       GO TO 100
  12623.   500 CONTINUE
  12624. C
  12625. C  CHECK FOR READ PERMISSION.
  12626. C
  12627.       L = LOCPRM(NAME,1)
  12628.       IF(L.EQ.0) GO TO 510
  12629.       CALL WARN(9,NAME,0)
  12630.       GO TO 100
  12631. C
  12632. C  GET THE RELATION DATA.
  12633. C
  12634. C
  12635. C  SEE IF ANY TUPLES EXIST.
  12636. C
  12637.   510 CONTINUE
  12638.       IF(NTUPLE.GT.0) GO TO 700
  12639.       WRITE (NOUT,602)
  12640.   602 FORMAT(43H -WARNING- NO DATA EXISTS FOR THIS RELATION )
  12641.       GO TO 100
  12642. C
  12643. C  SEE IF THERE IS A WHERE CLAUSE.
  12644. C
  12645.   700 CONTINUE
  12646.       K = LFIND(1,ITEMS,KWWHER,5)
  12647.       NBOO = 0
  12648.       LIMTU = ALL9S
  12649.       IF(K.EQ.0) GO TO 1000
  12650.       CALL WHERE(K)
  12651.       IF(RMSTAT.NE.0) GO TO 100
  12652. C
  12653. C  SEE IF ANY TUPLES SATISFY THE WHERE CLAUSE.
  12654. C
  12655.       CALL RMLOOK(IDUMMY,1,1,LENGTH)
  12656.       IF(RMSTAT.EQ.0) GO TO 900
  12657.       WRITE (NOUT,720)
  12658.   720 FORMAT(43H -WARNING- NO ROWS SATISFY THE WHERE CLAUSE )
  12659.       GO TO 100
  12660.   900 CONTINUE
  12661.       NID = CID
  12662.       IVAL = IVAL - 1
  12663.       LIMVAL = 0
  12664.       IF(NS.EQ.3) NS = 2
  12665. C
  12666. C  SEE IF SORTING IS NEEDED OR ASKED FOR.
  12667. C
  12668.  1000 CONTINUE
  12669.       IF(EQKEYW(1,KWCOMP,7)) GO TO 1500
  12670.       IF(EQKEYW(1,KWTALL,5)) GO TO 1100
  12671.       IF(.NOT.EQKEYW(J+2,KWSORT,6)) GO TO 1300
  12672. C
  12673. C  SORTING IS NEEDED. NATT IS THE ATTRIBUTE NAME.
  12674. C
  12675. C  SEE HOW MANY ATTRIBUTES ARE SPECIFIED IN THE SORT.
  12676. C
  12677.       NKSORT = 1
  12678.       I = J + 3
  12679.       L = LFIND(I,ITEMS,KWWHER,5)
  12680.       IF(L.EQ.0) L = ITEMS + 1
  12681.       NUMV = L - I - 1
  12682.       GO TO 1150
  12683. C
  12684. C  TALLY SORT - SET VARIABLES
  12685. C
  12686.  1100 CONTINUE
  12687.       NKSORT = 2
  12688.       I = 1
  12689.       NUMV = J-2
  12690.  1150 CONTINUE
  12691. C
  12692. C  NUMV IS THE NUMBER OF SORT ITEMS WE HAVE.
  12693. C  I IS THE START OF ATTRIBUTE SORT LIST - 1
  12694. C
  12695.       NSOVAR = 0
  12696.       N = 0
  12697.  1155 N = N + 1
  12698.       SAORD = .TRUE.
  12699.       ANAME = BLANK
  12700.       CALL LXSREC(I+N,1,8,ANAME,1)
  12701. C
  12702. C  CHECK FOR ASCENDING OR DESCENDING SORT
  12703. C
  12704.       IEQ = IBLANK
  12705.       CALL LXSREC(I+N+1,1,1,IEQ,1)
  12706.       IF(IEQ.NE.K4EQS) GO TO 1158
  12707.       N = N + 2
  12708.       CALL LXSREC(I+N,1,1,IEQ,1)
  12709.       IF((IEQ.NE.K4A).AND.(IEQ.NE.K4D)) GO TO 350
  12710.       IF(IEQ.EQ.K4D) SAORD = .FALSE.
  12711. C
  12712. C  GET THE ATTRIBUTE DATA
  12713. C
  12714.  1158 CONTINUE
  12715.       K = LOCATT(ANAME,NAME)
  12716.       CALL ATTGET(K)
  12717.       IF(K.EQ.0) GO TO 1160
  12718.       CALL WARN(3,ANAME,NAME)
  12719.       GO TO 100
  12720. C
  12721. C  SET UP THE ATTRIBUTE SORT DATA
  12722. C
  12723.  1160 CONTINUE
  12724.       NUMCOL = ATTCOL - 1
  12725.       IF(NKSORT.EQ.2) NUMCOL = 0
  12726. C
  12727. C  CHECK FOR VARIABLE LENGTH - SORTING ON VARIABLE LENGTH
  12728. C  ATTRIBUTES IS CURRENTLY NOT ALLOWED
  12729. C
  12730.       IF(ATTWDS.NE.0) GO TO 1170
  12731.       WRITE(NOUT,1165)
  12732.  1165 FORMAT(41H -WARNING- VARIABLE LENGTH ATTRIBUTES MAY,
  12733.      1       25H NOT BE SORTED OR TALLIED)
  12734.       GO TO 1200
  12735.  1170 CONTINUE
  12736. C
  12737. C  IF TEXT ATTRIBUTE DETERMINE THE NUMBER OF WORDS TO SORT ON - THIS
  12738. C  IS BASED ON THE NUMBER OF CHARACTERS (CURRENTLY 20) AND THE WORD
  12739. C  SIZE.
  12740. C     32 BIT WORDS - 20 CHARACTERS (5 WORDS)
  12741. C     60 BIT WORDS - 20 CHARACTERS (2 WORDS)
  12742. C     64 BIT WORDS - 16 CHARACTERS (2 WORDS)
  12743. C
  12744.       LSL = 1
  12745.       IF(ATTYPE.NE.KZTEXT) GO TO 1172
  12746. C
  12747. C  TEXT - DETERMINE SORT WORDS
  12748. C
  12749.       LSL = 20/CHPWD
  12750.       IF(ATTWDS.LT.LSL) LSL = ATTWDS
  12751. C
  12752. C  LOAD THE SORT ARRAYS
  12753. C
  12754.  1172 CONTINUE
  12755.       DO 1190 K=1,LSL
  12756.       NUMCOL = NUMCOL + 1
  12757.       NSOVAR = NSOVAR + 1
  12758. C
  12759. C  CHECK ON THE NUMBER OF SORT WORDS - CURRENTLY 10
  12760. C  THIS MAY WANT TO BE UPPED FOR THE SMALLER MACHINES
  12761. C
  12762.       IF(NSOVAR.LE.NSORTW) GO TO 1180
  12763.       WRITE(NOUT,1175)
  12764.  1175 FORMAT(44H -ERROR- ILLEGAL NUMBER OF SORTED ATTRIBUTES)
  12765.       GO TO 100
  12766. C
  12767. C  LOAD ARRAYS
  12768. C
  12769.  1180 CONTINUE
  12770.       SORTYP(NSOVAR) = SAORD
  12771.       VARPOS(NSOVAR) = NUMCOL
  12772.       IF(ATTYPE.EQ.KZINT) L=1
  12773.       IF(ATTYPE.EQ.KZREAL) L=2
  12774.       IF(ATTYPE.EQ.KZDOUB) L=3
  12775.       IF(ATTYPE.EQ.KZTEXT) L=4
  12776.       IF(ATTYPE.EQ.KZIVEC) L=1
  12777.       IF(ATTYPE.EQ.KZRVEC) L=2
  12778.       IF(ATTYPE.EQ.KZDVEC) L=3
  12779.       IF(ATTYPE.EQ.KZIMAT) L=1
  12780.       IF(ATTYPE.EQ.KZRMAT) L=2
  12781.       IF(ATTYPE.EQ.KZDMAT) L=3
  12782.       VARTYP(NSOVAR) = L
  12783.  1190 CONTINUE
  12784.  1200 CONTINUE
  12785.       IF(N.LT.NUMV) GO TO 1155
  12786. C
  12787. C  DO THE SORT.
  12788. C
  12789.       IF(NSOVAR.EQ.0) GO TO 100
  12790.       CALL SORT(NKSORT,IERR)
  12791.       IF(IERR.EQ.0)GOTO 1299
  12792.       WRITE(NOUT,1099)
  12793.  1099 FORMAT(44H ERROR FROM SORT ROUTINE OPENING SORTFIL.DAT)
  12794.       GOTO 100
  12795.  1299 CONTINUE
  12796.       NS = 1
  12797. C
  12798. C  CALL SELECT OR TALLY AS NEEDED.
  12799. C
  12800.  1300 CONTINUE
  12801.       IF(EQKEYW(1,KWTALL,5)) GO TO 1400
  12802.       CALL SELECT
  12803.       GO TO 100
  12804.  1400 CONTINUE
  12805.       CALL TALLY
  12806.       GO TO 100
  12807. C
  12808. C  CALL CMPUTE.
  12809. C
  12810.  1500 CONTINUE
  12811.       CALL CMPUTE
  12812.       GO TO 100
  12813. C
  12814. C  NEWPAGE COMMAND.
  12815. C
  12816.  1600 CONTINUE
  12817.       WRITE(NOUTR,1610)
  12818.  1610 FORMAT(1H1)
  12819.       GO TO 100
  12820.  2000 CONTINUE
  12821.       RETURN
  12822.       END
  12823.        SUBROUTINE RELADD
  12824.         Include TEXT.BLK
  12825. C
  12826. C  PURPOSE:   ADD A NEW TUPLE TO THE RELTBL RELATION
  12827. C
  12828.         Include TUPLER.BLK
  12829.         Include RELTBL.BLK
  12830.         Include F1COM.BLK
  12831.         Include FLAGS.BLK
  12832. C
  12833. C  GET THE PAGE FOR ADDING NEW TUPLES.
  12834. C
  12835.       MRSTRT = NRROW
  12836.       CALL RELPAG(MRSTRT)
  12837.       I = MRSTRT
  12838.       NRROW = NRROW + 1
  12839.       IF(I.EQ.RPBUF) NRROW = (RPBUF * LF1REC) + 1
  12840. C
  12841. C  MOVE THE DATA FROM THE TUPLE TO THE BUFFER.
  12842. C
  12843.       RELTBL(1,I) = NRROW
  12844.       CALL BLKMOV(RELTBL(2,I),NAME,2)
  12845.       CALL BLKMOV(RELTBL(4,I),RDATE,2)
  12846.       RELTBL(6,I) = NCOL
  12847.       RELTBL(7,I) = NATT
  12848.       RELTBL(8,I) = NTUPLE
  12849.       RELTBL(9,I) = RSTART
  12850.       RELTBL(10,I) = REND
  12851.       CALL BLKMOV(RELTBL(11,I),RPW,2)
  12852.       CALL BLKMOV(RELTBL(13,I),MPW,2)
  12853.       RELMOD = 1
  12854.       IFMOD = .TRUE.
  12855.       LRROW = 0
  12856.       IF(I.LT.RPBUF) RETURN
  12857. C
  12858. C  WE JUST FILLED A BUFFER. MAKE SURE RELTBL GETS THE NEXT ONE.
  12859. C
  12860.       RELBUF(1) = NRROW
  12861.       MRSTRT = NRROW
  12862.       CALL RELPAG(MRSTRT)
  12863.       RETURN
  12864.       END
  12865.       SUBROUTINE RELDEL
  12866.         Include TEXT.BLK
  12867. C
  12868. C  PURPOSE:   DELETE THE CURRENT TUPLE FROM THE RELTBL RELATION
  12869. C             BASED ON CONDITIONS SET UP IN LOCREL
  12870. C
  12871.         Include RELTBL.BLK
  12872.       IF(LRROW.EQ.0) GO TO 9999
  12873. C
  12874. C  CHANGE THE TUPLE STATUS FLAG TO DELETED.
  12875. C
  12876.       RELTBL(1,LRROW) = -RELTBL(1,LRROW)
  12877.       RELMOD = 1
  12878.  9999 CONTINUE
  12879.       RETURN
  12880.       END
  12881.       SUBROUTINE RELGET(STATUS)
  12882.         Include TEXT.BLK
  12883. C
  12884. C  PURPOSE:   GET THE NEXT TUPLE IN THE RELTBL RELATION
  12885. C
  12886. C  PARAMETERS:
  12887. C         STATUS--STATUS VARIABLE - 0 MEANS OK, 1 MEANS NO WAY
  12888.         Include RELTBL.BLK
  12889.         Include TUPLER.BLK
  12890.         Include MISC.BLK
  12891.       INTEGER STATUS
  12892.       LOGICAL EQ
  12893.       STATUS = 0
  12894. C
  12895. C  SCAN FOR THE NEXT RELATION.
  12896. C
  12897.       I = LRROW + 1
  12898.       GO TO 200
  12899.   100 CONTINUE
  12900.       CALL RELPAG(MRSTRT)
  12901.       I = MRSTRT
  12902.   200 CONTINUE
  12903.       IF(I.GT.RPBUF) GO TO 400
  12904.       IF(RELTBL(1,I).EQ.0) GO TO 9000
  12905.       IF(RELTBL(1,I).LT.0) GO TO 300
  12906.       IF(EQ(CNAME,BLANK)) GO TO 500
  12907.       IF(EQ(RELTBL(2,I),CNAME)) GO TO 500
  12908.   300 CONTINUE
  12909.       I = I + 1
  12910.       GO TO 200
  12911. C
  12912. C  GET THE NEXT PAGE.
  12913. C
  12914.   400 CONTINUE
  12915.       MRSTRT = RELBUF(1)
  12916.       IF(MRSTRT.EQ.0) GO TO 9000
  12917.       GO TO 100
  12918. C
  12919. C  FOUND IT.
  12920. C
  12921.   500 CONTINUE
  12922.       LRROW = I
  12923.       CALL BLKMOV(NAME,RELTBL(2,I),2)
  12924.       CALL BLKMOV(RDATE,RELTBL(4,I),2)
  12925.       NCOL = RELTBL(6,I)
  12926.       NATT = RELTBL(7,I)
  12927.       NTUPLE = RELTBL(8,I)
  12928.       RSTART = RELTBL(9,I)
  12929.       REND = RELTBL(10,I)
  12930.       CALL BLKMOV(RPW,RELTBL(11,I),2)
  12931.       CALL BLKMOV(MPW,RELTBL(13,I),2)
  12932.       GO TO 9999
  12933. C
  12934. C  UNABLE TO FIND WHAT WE ARE LOOKING FOR.
  12935. C
  12936.  9000 CONTINUE
  12937.       STATUS = 1
  12938.       LRROW = 0
  12939.  9999 CONTINUE
  12940.       RETURN
  12941.       END
  12942.       SUBROUTINE RELOAD
  12943.         Include TEXT.BLK
  12944. C
  12945. C  PURPOSE:   RELOAD THE DATA BASE TO RECOVER LOST SPACE FROM
  12946. C             DELETIONS.
  12947. C
  12948.         Include RMATTS.BLK
  12949.         Include CONST4.BLK
  12950.         Include CONST8.BLK
  12951.         Include RIMPTR.BLK
  12952.         Include TUPLEA.BLK
  12953.  
  12954.         Include TUPLER.BLK
  12955.         Include BUFFER.BLK
  12956.         Include START.BLK
  12957.         Include RIMCOM.BLK
  12958.         Include FLAGS.BLK
  12959.         Include MISC.BLK
  12960.         Include SRTCOM.BLK
  12961.         Include F2COM.BLK
  12962.         Include F3COM.BLK
  12963.         Include DCLAR1.BLK
  12964.         Include DCLAR4.BLK
  12965.         Include FILES.BLK
  12966. C
  12967. C  DIMENSION AND DATA
  12968. C
  12969.       INTEGER FILE4
  12970.       LOGICAL EQ
  12971.       INTEGER COLUMN
  12972.       INTEGER OFFSET
  12973.       CHARACTER*8 FNAME
  12974. C
  12975. C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
  12976. C
  12977.       FILE = K8ZFIL
  12978.       IFMOD = .TRUE.
  12979.       CALL RMDBLK(DBNAME)
  12980.       IF(RMSTAT.EQ.0) GO TO 50
  12981.       CALL WARN(RMSTAT,DBNAME,0)
  12982.       GO TO 9999
  12983.    50 CONTINUE
  12984.       IFMOD = .TRUE.
  12985. C
  12986. C  SET UP THE NEW DATA FILE.
  12987. C
  12988. C
  12989. C  FORM THE NAMES FOR FILE2 AND FILE3.
  12990. C
  12991.       DO 10 I=1,7
  12992.       CALL GETT(DBNAME,I,IT)
  12993.       IF(IT.EQ.IBLANK) GO TO 20
  12994.    10 CONTINUE
  12995.       I = 7
  12996.    20 CONTINUE
  12997.       RIMDB2 = BLANK
  12998.       CALL STRMOV(DBNAME,1,I,RIMDB2,1)
  12999.       CALL PUTT(RIMDB2,I,K42)
  13000.       RIMDB3 = RIMDB2
  13001.       CALL PUTT(RIMDB3,I,K43)
  13002.       FILE = RIMDB2
  13003.       FILE4 = 34
  13004.       WRITE(FNAME,30) FILE
  13005.    30 FORMAT(A8)
  13006. c
  13007. c LENBF2 is number of 32 bit words in a record...
  13008. c
  13009. c    LLENB=4*LENBF2
  13010.     LLENB=(LENBF2+1)/2
  13011. c In Absoft Fortran, max record size is 1024, so use 1/8 of
  13012. c the number of bytes (max 512 in practice) for size, and
  13013. c read 8 records per read instead of one.
  13014. c
  13015. C MS FORTRAN USES BYTES
  13016.       OPEN(UNIT=FILE4, FILE=FNAME, ACCESS='DIRECT',
  13017.      X     RECL=LLENB,FORM='UNFORMATTED',
  13018.      X     STATUS='NEW', IOSTAT=IOS)
  13019. C      OPEN(UNIT=FILE4, FILE=FNAME, ACCESS='DIRECT',
  13020. C     X     RECL=LENBF2, ORGANIZATION='SEQUENTIAL',
  13021. C     X     STATUS='NEW', IOSTAT=IOS)
  13022. C
  13023. C  INITIALIZE THIS FILE.
  13024. C
  13025.       CALL BLKCHG(4,LENBF2,1)
  13026.       KQ4 = BLKLOC(4)
  13027.       CALL ZEROIT(BUFFER(KQ4),LENBF2)
  13028.       CALL RIOOUT(FILE4,1,BUFFER(KQ4),LENBF2,IOS)
  13029.       KF4REC = 1
  13030.       IF(IOS.NE.0) RMSTAT = 2400 + IOS
  13031.       LF4REC = 1
  13032.       LF4WRD = 20
  13033. C
  13034. C  CYCLE THROUGH THE RELATIONS.
  13035. C
  13036.       I = LOCREL(BLANK)
  13037.       IF(I.NE.0) GO TO 9999
  13038.   100 CONTINUE
  13039.       CALL RELGET(ISTAT)
  13040.       IF(ISTAT.NE.0) GO TO 1000
  13041.       IF(NTUPLE.EQ.0) GO TO 100
  13042. C
  13043. C  START LOADING.
  13044. C
  13045.       NSTART = 0
  13046.       ID = NSTART
  13047.       NTUPLE = 0
  13048.       IDOLD = RSTART
  13049. C
  13050. C  GET A ROW FROM THE RELATION.
  13051. C
  13052.   200 CONTINUE
  13053.       IF(IDOLD.EQ.0) GO TO 600
  13054.       CALL ITOH(N1,N2,IDOLD)
  13055.       IF(N2.EQ.0) GO TO 600
  13056.       CALL GETDAT(1,IDOLD,LOCTUP,LENGTH)
  13057.       IF(IDOLD.LT.0) GO TO 200
  13058.       NTUPLE = NTUPLE + 1
  13059. C
  13060. C  UNPAC THE ID WORD.
  13061. C
  13062.       CALL ITOH(OFFSET,IOBN,ID)
  13063. C
  13064. C  CALCULATE THE NEW ID VALUE.
  13065. C
  13066.       IF(LF4WRD + LENGTH + 1 .LE. LENBF2) GO TO 300
  13067.       LF4REC = LF4REC + 1
  13068.       LF4WRD = 1
  13069.   300 CONTINUE
  13070.       CALL HTOI(LF4WRD,LF4REC,ID)
  13071.       IF(IOBN.EQ.0) GO TO 400
  13072. C
  13073. C  FIX UP THE ID POINTER SO IT POINTS TO THE NEXT TUPLE.
  13074. C
  13075.       KQ0 = BLKLOC(4) - 1
  13076.       ISIGN = 1
  13077.       BUFFER(KQ0 + OFFSET) = ISIGN * ID
  13078. C
  13079. C  NOW MOVE THE NEW TUPLE.
  13080. C
  13081.   400 CONTINUE
  13082.       CALL ITOH(OFFSET,IOBN,ID)
  13083. C
  13084.       IF(IOBN.EQ.KF4REC) GO TO 500
  13085. C
  13086. C  WE MUST DO PAGING.
  13087. C
  13088. C  WRITE OUT THE CURRENT BLOCK.
  13089. C
  13090.       KQ4 = BLKLOC(4)
  13091.       CALL RIOOUT(FILE4,KF4REC,BUFFER(KQ4),LENBF2,IOS)
  13092.       IF(IOS.NE.0) RMSTAT = 2400 + IOS
  13093. C
  13094. C  SET UP THE NEW BLOCK.
  13095. C
  13096.       CALL ZEROIT(BUFFER(KQ4),LENBF2)
  13097.       KF4REC = IOBN
  13098. C
  13099. C  WRITE OUT THE RECORD FOR THE FIRST TIME.
  13100. C
  13101.       CALL RIOOUT(FILE4,IOBN,BUFFER(KQ4),LENBF2,IOS)
  13102.       IF(IOS.NE.0) RMSTAT = 2400 + IOS
  13103.   500 CONTINUE
  13104. C
  13105. C  MOVE THE TUPLE TO THE PAGE.
  13106. C
  13107.       KQ0 = BLKLOC(4) - 1
  13108.       BUFFER(KQ0 + OFFSET) = 0
  13109.       BUFFER(KQ0 + OFFSET + 1) = LENGTH
  13110.       CALL BLKMOV(BUFFER(KQ0 + OFFSET + 2),BUFFER(LOCTUP),LENGTH)
  13111.       LF4WRD = LF4WRD + LENGTH + 2
  13112. C
  13113. C  ALL DONE RELOADING ONE TUPLE.
  13114. C
  13115.       IF(NSTART.EQ.0) NSTART = ID
  13116.       GO TO 200
  13117.   600 CONTINUE
  13118. C
  13119. C  RESET THE TUPLER VALUES.
  13120. C
  13121.       RSTART = NSTART
  13122.       REND = ID
  13123.       CALL RELPUT
  13124.       GO TO 100
  13125. C
  13126. C  DUMP THE LAST BUFFER FULL.
  13127. C
  13128.  1000 CONTINUE
  13129.       KQ4 = BLKLOC(4)
  13130.       CALL RIOOUT(FILE4,KF4REC,BUFFER(KQ4),LENBF2,IOS)
  13131.       CALL BLKCLR(4)
  13132. C
  13133. C  READ RECORD 1 BACK INTO INDEX BUFFER 1.
  13134. C
  13135.       CALL BLKCHG(1,LENBF2,1)
  13136.       KQ1 = BLKLOC(1)
  13137.       CALL RIOIN(FILE4,1,BUFFER(KQ1),LENBF2,IOS)
  13138. C
  13139. C  RESET THE OLD FLAGS IN F2COM.
  13140. C
  13141.       LF2REC = LF4REC
  13142.       LF2WRD = LF4WRD
  13143.       CURBLK(1) = 1
  13144.       CURBLK(2) = 0
  13145.       CURBLK(3) = 0
  13146.       MODFLG(1) = 1
  13147.       MODFLG(2) = 0
  13148.       MODFLG(3) = 0
  13149.       ITEMP = FILE2
  13150.       CLOSE(UNIT=FILE2,IOSTAT=IOS)
  13151.       FILE2 = FILE4
  13152.       CALL F2CLO
  13153.       CLOSE(UNIT=FILE4,IOSTAT=IOS)
  13154.       FILE2 = ITEMP
  13155.       CALL F2OPN(RIMDB2)
  13156. C
  13157. C  NOW REMAKE THE BTREE FILE.
  13158. C
  13159.       CLOSE(FILE3,STATUS='DELETE',IOSTAT=IOS)
  13160.       CALL F3OPN(RIMDB3)
  13161. C
  13162. C  CYCLE THROUGH THE RELATIONS.
  13163. C
  13164.       I = LOCREL(BLANK)
  13165. C
  13166. C  GET A RELATION.
  13167. C
  13168.  2000 CONTINUE
  13169.       CALL RELGET(ISTAT)
  13170.       IF(ISTAT.NE.0) GO TO 3100
  13171.       RNAME = NAME
  13172.       NID = RSTART
  13173.       IID = NID
  13174.       I = LOCATT(BLANK,RNAME)
  13175.       IF(I.NE.0) GO TO 2000
  13176.  2100 CONTINUE
  13177.       CALL ATTGET(ISTAT)
  13178.       IF(ISTAT.NE.0) GO TO 2000
  13179.       IF(ATTKEY.EQ.0) GO TO 2100
  13180.       ANAME = ATTNAM
  13181.       NID = IID
  13182. C
  13183. C  DETERMINE THE COLUMN TO BE USED FOR THIS ATTRIBUTE.
  13184. C
  13185.       COLUMN = ATTCOL
  13186. C
  13187. C  INITIALIZE THE BTREE FOR THIS ELEMENT.
  13188. C
  13189.       CALL BTINIT(ATTKEY)
  13190.       START = ATTKEY
  13191.       CALL ATTPUT(ISTAT)
  13192. C
  13193. C  SORT THE KEY VALUES IF THERE ARE MORE THAN 100 OF THEM
  13194. C
  13195.       IF(NTUPLE.GT.100) GO TO 2700
  13196. C
  13197. C   SCAN THROUGH ALL THE DATA FOR THIS RELATION.
  13198. C
  13199.  2500 CONTINUE
  13200.       IF(NID.EQ.0) GO TO 2900
  13201.       CALL ITOH(N1,N2,NID)
  13202.       IF(N2.EQ.0) GO TO 2900
  13203.       CID = NID
  13204.       CALL GETDAT(1,NID,ITUP,LENGTH)
  13205.       IF(NID.LT.0) GO TO 2900
  13206.       IP = ITUP + COLUMN - 1
  13207.       IF(ATTWDS.NE.0) GO TO 2600
  13208. C
  13209. C  ATTRIBUTE IS A VARIABLE LENGTH ATTRIBUTE.
  13210. C
  13211.       IP = BUFFER(IP) + ITUP + 1
  13212.  2600 CONTINUE
  13213.       IF(BUFFER(IP).EQ.NULL) GO TO 2500
  13214.       CALL BTADD(BUFFER(IP),CID,ATTYPE)
  13215.       GO TO 2500
  13216. C
  13217. C  SORT KEY VALUES BEFORE BUILDING THE B-TREE
  13218. C
  13219.  2700 CONTINUE
  13220.       LENGTH = 2
  13221.       NSOVAR = 1
  13222.       NKSORT = 3
  13223.       SORTYP(1) = .TRUE.
  13224.       VARPOS(1) = 1
  13225.       L = 2
  13226.       IF(ATTYPE.EQ.KZTEXT) L = 4
  13227.       IF(ATTYPE.EQ.KZINT ) L = 1
  13228.       IF(ATTYPE.EQ.KZIVEC) L = 1
  13229.       IF(ATTYPE.EQ.KZIMAT) L = 1
  13230.       VARTYP(1) = L
  13231.       CALL SORT(NKSORT,IERR)
  13232.       IF(IERR.EQ.0)GOTO 1790
  13233.       WRITE(NOUT,1777)
  13234.  1777 FORMAT(36H ERROR -- COULD NOT OPEN SORTFIL.DAT)
  13235.       GOTO 9999
  13236.  1790 CONTINUE
  13237. C
  13238. C  READ THE SORTED KEY VALUES AND BUILD THE BTREE
  13239. C
  13240.       CALL GTSORT(IP,1,-1,LENGTH)
  13241.  2800 CONTINUE
  13242.       CALL GTSORT(IP,1,1,LENGTH)
  13243.       IF(RMSTAT.NE.0) GO TO 2900
  13244.       IF(BUFFER(IP).EQ.NULL) GO TO 2800
  13245.       CALL BTADD(BUFFER(IP),BUFFER(2),ATTYPE)
  13246.       GO TO 2800
  13247. C
  13248. C  ALL DONE.
  13249. C
  13250.  2900 CONTINUE
  13251. C
  13252. C  RESTORE THE START TO THE BTREE TABLE.
  13253. C
  13254.       I = LOCATT(ANAME,RNAME)
  13255.       CALL ATTGET(ISTAT)
  13256.       ATTKEY = START
  13257.       CALL ATTPUT(ISTAT)
  13258. C
  13259. C  RESET OUR LOCATION GOING THROUGH THE ATTRIBUTES FOR RNAME.
  13260. C
  13261.       I = LOCATT(BLANK,RNAME)
  13262.  3000 CONTINUE
  13263.       CALL ATTGET(ISTAT)
  13264.       IF(ISTAT.NE.0) GO TO 2000
  13265.       IF(EQ(ATTNAM,ANAME)) GO TO 2100
  13266.       GO TO 3000
  13267. C
  13268. C  COPY THE NEW BTREE FILE OVER THE OLD ONE.
  13269. C
  13270.  3100 CONTINUE
  13271. C
  13272. C  RETURN
  13273. C
  13274.  9999 CONTINUE
  13275.       RETURN
  13276.       END
  13277.       SUBROUTINE RELPAG(THEROW)
  13278.         Include TEXT.BLK
  13279. C
  13280. C  PURPOSE:   DO PAGING AS NEEDED FOR THE RELTBL RELATION
  13281. C
  13282. C  PARAMETERS:
  13283. C         THEROW--INPUT - ROW WANTED
  13284. C                 OUTPUT - ACTUAL ROW TO USE IN THE BUFFER
  13285.         Include RELTBL.BLK
  13286.         Include RIMCOM.BLK
  13287.         Include F1COM.BLK
  13288.       INTEGER THEROW
  13289. C
  13290. C  TURN THE REQUESTED ROW INTO A RECORD AND OFFSET.
  13291. C
  13292.       NNREC = ((THEROW - 1) / RPBUF) + 1
  13293.       NNROW = THEROW - ((NNREC - 1) * RPBUF)
  13294. C
  13295. C  SEE IF WE ALREADY HAVE THIS RECORD IN THE BUFFER.
  13296. C
  13297.       IF(NNREC.EQ.CRREC) GO TO 300
  13298. C
  13299. C  WE MUST DO PAGING.
  13300. C
  13301. C  SEE IF THE CURRENT RECORD IN THE BUFFER HAS BEEN MODIFIED.
  13302. C
  13303.       IF(RELMOD.EQ.0) GO TO 100
  13304. C
  13305. C  WRITE OUT THE CURRENT RECORD.
  13306. C
  13307.       CALL RIOOUT(FILE1,CRREC,RELBUF,LENBF1,IOS)
  13308.       IF(IOS.NE.0) RMSTAT = 2100 + IOS
  13309. C
  13310. C  READ IN THE NEEDED RECORD.
  13311. C
  13312.   100 CONTINUE
  13313.       RELMOD = 0
  13314.       IF(NNREC.GT.LF1REC) GO TO 150
  13315.       CALL RIOIN(FILE1,NNREC,RELBUF,LENBF1,IOS)
  13316.       IF(IOS.EQ.0) GO TO 200
  13317. C
  13318. C  THERE WAS NO DATA ON THE FILE - WRITE SOME.
  13319. C
  13320.   150 CONTINUE
  13321.       CALL ZEROIT(RELBUF,LENBF1)
  13322.       CALL RIOOUT(FILE1,NNREC,RELBUF,LENBF1,IOS)
  13323.       IF(IOS.NE.0) RMSTAT = 2100 + IOS
  13324.       LF1REC = LF1REC + 1
  13325.   200 CONTINUE
  13326.       CRREC = NNREC
  13327. C
  13328. C  SET THE POINTER TO THE ACTUAL ROW IN THE BUFFER.
  13329. C
  13330.   300 CONTINUE
  13331.       THEROW = NNROW
  13332.       RETURN
  13333.       END
  13334.       SUBROUTINE RELPUT
  13335.         Include TEXT.BLK
  13336. C
  13337. C  PURPOSE:   REPLACE THE CURRENT TUPLE FROM THE RELTBL RELATION
  13338. C             BASED ON CONDITIONS SET UP IN LOCREL
  13339. C
  13340.         Include FLAGS.BLK
  13341.         Include TUPLER.BLK
  13342.         Include RELTBL.BLK
  13343.       IF(LRROW.EQ.0) GO TO 9999
  13344. C
  13345. C  MOVE THE STUFF TO ROW LRROW.
  13346. C
  13347.       CALL BLKMOV(RELTBL(2,LRROW),NAME,2)
  13348.       CALL BLKMOV(RELTBL(4,LRROW),RDATE,2)
  13349.       RELTBL(6,LRROW) = NCOL
  13350.       RELTBL(7,LRROW) = NATT
  13351.       RELTBL(8,LRROW) = NTUPLE
  13352.       RELTBL(9,LRROW) = RSTART
  13353.       RELTBL(10,LRROW) = REND
  13354.       CALL BLKMOV(RELTBL(11,LRROW),RPW,2)
  13355.       CALL BLKMOV(RELTBL(13,LRROW),MPW,2)
  13356.       RELMOD = 1
  13357.       IFMOD = .TRUE.
  13358.  9999 CONTINUE
  13359.       RETURN
  13360.       END
  13361.       SUBROUTINE REUSE
  13362.         Include TEXT.BLK
  13363. C
  13364. C  PURPOSE:    RESET THE USAGE FLAGS TO OFF IN THE ICORE FLAGS
  13365. C
  13366.         Include F3COM.BLK
  13367.       DO 100 NUMB=1,NUMIC
  13368.       ICORE(1,NUMB) = 0
  13369.   100 CONTINUE
  13370.       RETURN
  13371.       END
  13372.       SUBROUTINE RIOIN(FILE,RECORD,BUFFER,NWDS,IOS)
  13373.         Include TEXT.BLK
  13374. C
  13375. C  PURPOSE:   COVER ROUTINE FOR RANDOM INPUT - VAX VERSION
  13376. C
  13377. C  PARAMETERS:
  13378. C         FILE----ARRAY WITH A FET
  13379. C         RECORD--RECORD NUMBER WANTED
  13380. C         BUFFER--BUFFER TO READ INTO
  13381. C         NWDS----NUMBER OF WORDS PER BUFFER
  13382. C         IOS-----STATUS VARIABLE - 0 MEANS SUCCESS, ELSE TILT
  13383. C
  13384.       INTEGER FILE
  13385.       INTEGER RECORD
  13386.       INTEGER BUFFER(1)
  13387.     Logical ISITIN
  13388.     Integer FILSIZ,Isz,LnByt
  13389. c for Absoft Fortran, we use record length of 1/8 the number
  13390. c of bytes actually needed. Therefore do 8 real reads on the
  13391. c file here...
  13392. c
  13393. c Isz is size expected for file
  13394.     LnByt=4*NWDS
  13395.     Isz=LnByt*Record
  13396. c If the file is a new one, we must not try to read it.
  13397.     IOS=1
  13398.     Inquire(UNIT=file,exist=ISITIN,size=FILSIZ)
  13399.     If(.not.ISITIN)Return
  13400.     If(FILSIZ.LT.Isz)Return
  13401. c above should handle new files and just return
  13402. c even if the file is brand new.
  13403. c Caller expects IOS to return nonzero if file is new.
  13404. c Also handle cases where file is too short and needs to be extended.
  13405.     IOS=0
  13406.     IF(LNBYT.GT.1000)goto 30
  13407.         READ(FILE,REC=RECORD,IOSTAT=IOS) (BUFFER(I),I=1,NWDS)
  13408.     Return
  13409. 30    Continue
  13410.     LOREC=(RECORD-1)*8 + 1
  13411.     LHIREC=LOREC+7
  13412.     NWD8=(NWDS+7)/8
  13413.     II=1
  13414.     DO 100 N=LOREC,LHIREC
  13415.     IV=II+NWD8-1
  13416.     If(IV.GT.NWDS)iv=nwds
  13417.     READ(FILE,REC=N,IOSTAT=IOS)(BUFFER(III),III=II,IV)
  13418.     II=II+NWD8
  13419. 100    CONTINUE
  13420. C done all 8 records now...
  13421. c
  13422.       RETURN
  13423.       END
  13424.       SUBROUTINE RIOOPN(FNAME,FILE,NWDS,IOS)
  13425.         Include TEXT.BLK
  13426. C
  13427. C  PURPOSE:   COVER ROUTINE TO OPEN A RANDOM FILE
  13428. C
  13429. C  PARAMETERS:
  13430. C         FNAME---NAME OF THE FILE TO OPEN
  13431. C         FILE----ARRAY WITH A FET
  13432. C         NWDS----NUMBER OF WORDS PER RECORD
  13433. C         IOS-----STATUS VARIABLE - O MEANS SUCCESS, ELSE TILT
  13434. C
  13435.         Include RIO.BLK
  13436.       REAL*8 FNAME
  13437.     LOGICAL ISITIN
  13438.       CHARACTER*8 NAME
  13439.       INTEGER FILE
  13440.       WRITE(NAME,100) FNAME
  13441.   100 FORMAT(A8)
  13442.     INQUIRE(FILE=NAME,EXIST=ISITIN)
  13443. c    LNWDS=4*NWDS
  13444. c absoft adjustment
  13445.     lnbyt=nwds*4
  13446.     LNWDS=(NWDS+1)/2
  13447.     If(lnbyt.le.1000)LNWDS=LNBYT
  13448. C MS FORTRAN USES BYTE LENGTHS ALWAYS
  13449.     IF(ISITIN)GOTO 150
  13450. C OPEN WITH BINARY FORMAT SO WE GET NO RECORD
  13451. C LENGTH OVERHEAD HERE.
  13452. C (MS FORTRAN ONLY)
  13453.       OPEN(UNIT=FILE, FILE=NAME, ACCESS='DIRECT',
  13454.      X     RECL=LNWDS,FORM='UNFORMATTED',
  13455.      X     STATUS='NEW',IOSTAT=IOS)
  13456.     GOTO 160
  13457. 150    CONTINUE
  13458.       OPEN(UNIT=FILE, FILE=NAME, ACCESS='DIRECT',
  13459.      X     RECL=LNWDS,FORM='UNFORMATTED',
  13460.      X     STATUS='OLD',IOSTAT=IOS)
  13461. 160    CONTINUE
  13462. C      OPEN(UNIT=FILE, FILE=NAME, ACCESS='DIRECT',
  13463. C     X     RECL=NWDS, ORGANIZATION='SEQUENTIAL',
  13464. C     X     STATUS='UNKNOWN',IOSTAT=IOS)
  13465. CC     X     STATUS='UNKNOWN',IOSTAT=IOS,SHARED)
  13466.       IUN = FILE - 29
  13467.       IRECPS(IUN) = 0
  13468.       RETURN
  13469.       END
  13470.       SUBROUTINE RIOOUT(FILE,RECORD,BUFFER,NWDS,IOS)
  13471.         Include TEXT.BLK
  13472. C
  13473. C  PURPOSE:   COVER ROUTINE FOR RANDOM OUTPUT - VAX VERSION
  13474. C
  13475. C  PARAMETERS:
  13476. C         FILE----ARRAY WITH A FET
  13477. C         RECORD--RECORD NUMBER WANTED
  13478. C         BUFFER--BUFFER TO WRITE FROM
  13479. C         NWDS----NUMBER OF WORDS PER BUFFER
  13480. C         IOS-----STATUS VARIABLE - 0 MEANS SUCCESS, ELSE TILT
  13481. C
  13482.         Include RIO.BLK
  13483.       INTEGER FILE
  13484.       INTEGER RECORD,LNBYT
  13485.       INTEGER BUFFER(1)
  13486.     LNBYT=NWDS*4
  13487.       IUN = FILE - 29
  13488.       IRECPS(IUN) = IRECPS(IUN) + 1
  13489.       IF(RECORD.EQ.0) GO TO 100
  13490. c Absoft fortran limits of 1024 bytes forced us to use 1/8 size
  13491. c buffers. Compensate here.
  13492. c    LNBYT=NWDS*4
  13493.     If(LNBYT.LE.1000)goto 450
  13494.     LOREC=(RECORD-1)*8 + 1
  13495.     LHIREC=LOREC+7
  13496.     NWD8=(NWDS+7)/8
  13497.     II=1
  13498.     DO 110 NNN=LOREC,LHIREC
  13499.     IV=II+NWD8-1
  13500.     If(IV.GT.NWDS)IV=NWDS
  13501. c Absoft code rot fix
  13502. c    Rewind File 
  13503.     WRITE(FILE,REC=NNN,IOSTAT=IOS)(BUFFER(III),III=II,IV)
  13504. c    Rewind File
  13505.     II=II+NWD8
  13506. 110    CONTINUE
  13507.     Return
  13508. 450    Continue
  13509. C
  13510.        WRITE(FILE,REC=RECORD,IOSTAT=IOS) (BUFFER(I),I=1,NWDS)
  13511.       RETURN
  13512.   100 CONTINUE
  13513.       N = IRECPS(IUN)
  13514. c Absoft fortran limits of 1024 bytes forced us to use 1/8 size
  13515. c buffers. Compensate here.
  13516.     If(LNBYT.LE.1000)goto 455
  13517.     LOREC=(N-1)*8 + 1
  13518.     LHIREC=LOREC+7
  13519.     NWD8=(NWDS+7)/8
  13520.     II=1
  13521.     DO 120 NNN=LOREC,LHIREC
  13522.     IV=II+NWD8-1
  13523.     If(IV.GT.NWDS)IV=NWDS
  13524. c Absoft code rot fix
  13525. c    Rewind File
  13526.     WRITE(FILE,REC=NNN,IOSTAT=IOS)(BUFFER(III),III=II,IV)
  13527. c    Rewind File
  13528.     II=II+NWD8
  13529. 120    CONTINUE
  13530.     Return
  13531. 455    Continue
  13532. C
  13533.        WRITE(FILE,REC=N,IOSTAT=IOS) (BUFFER(I),I=1,NWDS)
  13534.       RETURN
  13535.       END
  13536.       SUBROUTINE RMCLOS
  13537.         Include TEXT.BLK
  13538. C
  13539. C  PURPOSE:   CLOSE A RIM DATABASE.
  13540. C
  13541.         Include RIMCOM.BLK
  13542.         Include CONST8.BLK
  13543.         Include FLAGS.BLK
  13544.         Include DCLAR4.BLK
  13545. C
  13546. C  CLOSE THE MULTIPLE RMFIND SAVE FILE - ZZRIMZZ
  13547. C
  13548.       FILE = K8ZFIL
  13549.       CALL DROPF(FILE)
  13550. C
  13551. C  DO NOT CLOSE THE DATABASE IF THERE WERE NO MODIFICATIONS
  13552. C
  13553.       RMSTAT = 0
  13554.       IF(.NOT.DFLAG) RETURN
  13555.       DFLAG = .FALSE.
  13556.       IF(.NOT.IFMOD) RETURN
  13557. C
  13558. C  RESET THE DATABASE DATE AND TIME.
  13559. C
  13560.       CALL RMDATE(DBDATE)
  13561.       CALL RMTIME(DBTIME)
  13562. C
  13563. C  CLOSE THE THREE DATABASE FILES.
  13564. C
  13565.       CALL F1CLO
  13566.       CALL F2CLO
  13567.       CALL F3CLO
  13568.       DFLAG = .FALSE.
  13569.       IFMOD = .FALSE.
  13570.       RETURN
  13571.       END
  13572.       SUBROUTINE RMCON2
  13573. C
  13574. C  PURPOSE:  THIS ROUTINE INITIALIZES THE HOLLERITH CONSTANTS USED
  13575. C            BY RIM. THE CODE IS MACHINE DEPENDENT.  IT IS CALLED
  13576. C            BY RMCONS
  13577. C
  13578.         Include RMATTS.BLK
  13579.         Include RMKEYW.BLK
  13580.       REAL*8  JWBY,JWEQ,JWIN,JWIS,JWTO,
  13581.      X        JWALL,JWEND,JWFOR,JWINT,JWKEY,JWMPW,JWRPW,JWVAR,JWZIP,
  13582.      X        JWDATE,JWDMAT,JWDVEC,JWECHO,JWEXIT,JWFROM,JWHELP,JWIMAT,
  13583.      X        JWIVEC,JWJOIN,JWLOAD,JWMENU,JWOPEN,JWQUIT,JWREAD,JWREAL,
  13584.      X        JWRMAT,JWROWS,JWRULE,JWRVEC,JWTEXT,JWUSER,JWWITH,JWBLAN,
  13585.      X        JWBUIL,JWCHEC,JWCLOS,JWCOUN,JWINPU,JWLIMI,JWLINE,JWOWNE,
  13586.      X        JWPRIN,JWRULS,JWTALL,JWTITL,JWUSIN,JWWHER,JWWIDT,JWCHAN,
  13587.      X        JWDEFI,JWDELE,JWDOUB,JWMODI,JWNOEC,JWOUTP,JWRELO,JWREMO,
  13588.      X        JWRENA,JWSELE,JWSORT,JWTUPL,JWUNLO,JWCOMP,JWEXHI,JWFORM,
  13589.      X        JWLIST,JWNEWP,JWNOCH,JWPERC,JWPROJ,JWATTR,JWDUPL,JWELEM,
  13590.      X        JWINTS,JWPASS,JWRELA,JWSUBT,JWTERM,JWTOLE
  13591. C ***
  13592.     EQUIVALENCE (CWBY,JWBY)
  13593.     EQUIVALENCE (CWEQ,JWEQ)
  13594.     EQUIVALENCE (CWIN,JWIN)
  13595.     EQUIVALENCE (CWIS,JWIS)
  13596.     EQUIVALENCE (CWTO,JWTO)
  13597.     EQUIVALENCE (CWALL,JWALL)
  13598.     EQUIVALENCE (CWEND,JWEND)
  13599.     EQUIVALENCE (CWFOR,JWFOR)
  13600.     EQUIVALENCE (CWINT,JWINT)
  13601.     EQUIVALENCE (CWKEY,JWKEY)
  13602.     EQUIVALENCE (CWMPW,JWMPW)
  13603.     EQUIVALENCE (CWRPW,JWRPW)
  13604.     EQUIVALENCE (CWVAR,JWVAR)
  13605.     EQUIVALENCE (CWZIP,JWZIP)
  13606.     EQUIVALENCE (CWDATE,JWDATE)
  13607.     EQUIVALENCE (CWDMAT,JWDMAT)
  13608.     EQUIVALENCE (CWDVEC,JWDVEC)
  13609.     EQUIVALENCE (CWECHO,JWECHO)
  13610.     EQUIVALENCE (CWEXIT,JWEXIT)
  13611.     EQUIVALENCE (CWFROM,JWFROM)
  13612.     EQUIVALENCE (CWHELP,JWHELP)
  13613.     EQUIVALENCE (CWIMAT,JWIMAT)
  13614.     EQUIVALENCE (CWIVEC,JWIVEC)
  13615.     EQUIVALENCE (CWJOIN,JWJOIN)
  13616.     EQUIVALENCE (CWLOAD,JWLOAD)
  13617.     EQUIVALENCE (CWMENU,JWMENU)
  13618.     EQUIVALENCE (CWOPEN,JWOPEN)
  13619.     EQUIVALENCE (CWQUIT,JWQUIT)
  13620.     EQUIVALENCE (CWREAD,JWREAD)
  13621.     EQUIVALENCE (CWREAL,JWREAL)
  13622.     EQUIVALENCE (CWRMAT,JWRMAT)
  13623.     EQUIVALENCE (CWROWS,JWROWS)
  13624.     EQUIVALENCE (CWRULE,JWRULE)
  13625.     EQUIVALENCE (CWRVEC,JWRVEC)
  13626.     EQUIVALENCE (CWTEXT,JWTEXT)
  13627.     EQUIVALENCE (CWUSER,JWUSER)
  13628.     EQUIVALENCE (CWWITH,JWWITH)
  13629.     EQUIVALENCE (CWBLAN,JWBLAN)
  13630.     EQUIVALENCE (CWBUIL,JWBUIL)
  13631.     EQUIVALENCE (CWCHEC,JWCHEC)
  13632.     EQUIVALENCE (CWCLOS,JWCLOS)
  13633.     EQUIVALENCE (CWCOUN,JWCOUN)
  13634.     EQUIVALENCE (CWINPU,JWINPU)
  13635.     EQUIVALENCE (CWLIMI,JWLIMI)
  13636.     EQUIVALENCE (CWLINE,JWLINE)
  13637.     EQUIVALENCE (CWOWNE,JWOWNE)
  13638.     EQUIVALENCE (CWPRIN,JWPRIN)
  13639.     EQUIVALENCE (CWRULS,JWRULS)
  13640.     EQUIVALENCE (CWTALL,JWTALL)
  13641.     EQUIVALENCE (CWTITL,JWTITL)
  13642.     EQUIVALENCE (CWUSIN,JWUSIN)
  13643.     EQUIVALENCE (CWWHER,JWWHER)
  13644.     EQUIVALENCE (CWWIDT,JWWIDT)
  13645.     EQUIVALENCE (CWCHAN,JWCHAN)
  13646.     EQUIVALENCE (CWDEFI,JWDEFI)
  13647.     EQUIVALENCE (CWDELE,JWDELE)
  13648.     EQUIVALENCE (CWDOUB,JWDOUB)
  13649.     EQUIVALENCE (CWMODI,JWMODI)
  13650.     EQUIVALENCE (CWNOEC,JWNOEC)
  13651.     EQUIVALENCE (CWOUTP,JWOUTP)
  13652.     EQUIVALENCE (CWRELO,JWRELO)
  13653.     EQUIVALENCE (CWREMO,JWREMO)
  13654.     EQUIVALENCE (CWRENA,JWRENA)
  13655.     EQUIVALENCE (CWSELE,JWSELE)
  13656.     EQUIVALENCE (CWSORT,JWSORT)
  13657.     EQUIVALENCE (CWTUPL,JWTUPL)
  13658.     EQUIVALENCE (CWUNLO,JWUNLO)
  13659.     EQUIVALENCE (CWCOMP,JWCOMP)
  13660.     EQUIVALENCE (CWEXHI,JWEXHI)
  13661.     EQUIVALENCE (CWFORM,JWFORM)
  13662.     EQUIVALENCE (CWLIST,JWLIST)
  13663.     EQUIVALENCE (CWNEWP,JWNEWP)
  13664.     EQUIVALENCE (CWNOCH,JWNOCH)
  13665.     EQUIVALENCE (CWPERC,JWPERC)
  13666.     EQUIVALENCE (CWPROJ,JWPROJ)
  13667.     EQUIVALENCE (CWATTR,JWATTR)
  13668.     EQUIVALENCE (CWDUPL,JWDUPL)
  13669.     EQUIVALENCE (CWELEM,JWELEM)
  13670.     EQUIVALENCE (CWINTS,JWINTS)
  13671.     EQUIVALENCE (CWPASS,JWPASS)
  13672.     EQUIVALENCE (CWRELA,JWRELA)
  13673.     EQUIVALENCE (CWSUBT,JWSUBT)
  13674.     EQUIVALENCE (CWTERM,JWTERM)
  13675.     EQUIVALENCE (CWTOLE,JWTOLE)
  13676.       CHARACTER*8  CWBY,CWEQ,CWIN,CWIS,CWTO,
  13677.      X        CWALL,CWEND,CWFOR,CWINT,CWKEY,CWMPW,CWRPW,CWVAR,CWZIP,
  13678.      X        CWDATE,CWDMAT,CWDVEC,CWECHO,CWEXIT,CWFROM,CWHELP,CWIMAT,
  13679.      X        CWIVEC,CWJOIN,CWLOAD,CWMENU,CWOPEN,CWQUIT,CWREAD,CWREAL,
  13680.      X        CWRMAT,CWROWS,CWRULE,CWRVEC,CWTEXT,CWUSER,CWWITH,CWBLAN,
  13681.      X        CWBUIL,CWCHEC,CWCLOS,CWCOUN,CWINPU,CWLIMI,CWLINE,CWOWNE,
  13682.      X        CWPRIN,CWRULS,CWTALL,CWTITL,CWUSIN,CWWHER,CWWIDT,CWCHAN,
  13683.      X        CWDEFI,CWDELE,CWDOUB,CWMODI,CWNOEC,CWOUTP,CWRELO,CWREMO,
  13684.      X        CWRENA,CWSELE,CWSORT,CWTUPL,CWUNLO,CWCOMP,CWEXHI,CWFORM,
  13685.      X        CWLIST,CWNEWP,CWNOCH,CWPERC,CWPROJ,CWATTR,CWDUPL,CWELEM,
  13686.      X        CWINTS,CWPASS,CWRELA,CWSUBT,CWTERM,CWTOLE
  13687.     CHARACTER*4 JZVEC,JZMAT,JZVAR,JZINT,JZREAL,JZDOUB
  13688.     CHARACTER*4 JZTEXT,JZIVEC,JZRVEC,JZDVEC,JZIMAT
  13689.     CHARACTER*4 JZRMAT,JZDMAT
  13690. C
  13691. C  VARIABLES USED BY THE RMATTS COMMON BLOCK
  13692. C
  13693.       DATA JZVEC  /'VEC'/
  13694.       DATA JZMAT  /'MAT'/
  13695.       DATA JZVAR  /'VAR'/
  13696.       DATA JZINT  /'INT'/
  13697.       DATA JZREAL /'REAL'/
  13698.       DATA JZDOUB /'DOUB'/
  13699.       DATA JZTEXT /'TEXT'/
  13700.       DATA JZIVEC /'IVEC'/
  13701.       DATA JZRVEC /'RVEC'/
  13702.       DATA JZDVEC /'DVEC'/
  13703.       DATA JZIMAT /'IMAT'/
  13704.       DATA JZRMAT /'RMAT'/
  13705.       DATA JZDMAT /'DMAT'/
  13706. C
  13707. C  VARIABLES USED BY THE RMKEYW COMMON BLOCK
  13708. C
  13709.       DATA CWBY   / 'BY'       /
  13710.       DATA CWEQ   / 'EQ'     /
  13711.       DATA CWIN   / 'IN'       /
  13712.       DATA CWIS   / 'IS'       /
  13713.       DATA CWTO   / 'TO'       /
  13714.       DATA CWALL  / 'ALL'      /
  13715.       DATA CWEND  / 'END'      /
  13716.       DATA CWFOR  / 'FOR'      /
  13717.       DATA CWINT  / 'INTEGER'  /
  13718.       DATA CWKEY  / 'KEY'      /
  13719.       DATA CWMPW  / 'MPW'      /
  13720.       DATA CWRPW  / 'RPW'      /
  13721.       DATA CWVAR  / 'VAR'      /
  13722.       DATA CWZIP  / 'ZIP'      /
  13723.       DATA CWDATE / 'DATE'     /
  13724.       DATA CWDMAT / 'DMAT'     /
  13725.       DATA CWDVEC / 'DVEC'     /
  13726.       DATA CWECHO / 'ECHO'     /
  13727.       DATA CWEXIT / 'EXIT'     /
  13728.       DATA CWFROM / 'FROM'     /
  13729.       DATA CWHELP / 'HELP'     /
  13730.       DATA CWIMAT / 'IMAT'     /
  13731.       DATA CWIVEC / 'IVEC'     /
  13732.       DATA CWJOIN / 'JOIN'     /
  13733.       DATA CWLOAD / 'LOAD'     /
  13734.       DATA CWMENU / 'MENU'     /
  13735.       DATA CWOPEN / 'OPEN'     /
  13736.       DATA CWQUIT / 'QUIT'     /
  13737.       DATA CWREAD / 'READ'     /
  13738.       DATA CWREAL / 'REAL'     /
  13739.       DATA CWRMAT / 'RMAT'     /
  13740.       DATA CWROWS / 'ROWS'     /
  13741.       DATA CWRULE / 'RULE'     /
  13742.       DATA CWRVEC / 'RVEC'     /
  13743.       DATA CWTEXT / 'TEXT'     /
  13744.       DATA CWUSER / 'USER'     /
  13745.       DATA CWWITH / 'WITH'     /
  13746.       DATA CWBLAN / 'BLANK'    /
  13747.       DATA CWBUIL / 'BUILD'    /
  13748.       DATA CWCHEC / 'CHECK'    /
  13749.       DATA CWCLOS / 'CLOSE'    /
  13750.       DATA CWCOUN / 'COUNT'    /
  13751.       DATA CWINPU / 'INPUT'    /
  13752.       DATA CWLIMI / 'LIMIT'    /
  13753.       DATA CWLINE / 'LINES'    /
  13754.       DATA CWOWNE / 'OWNER'    /
  13755.       DATA CWPRIN / 'PRINT'    /
  13756.       DATA CWRULS / 'RULES'    /
  13757.       DATA CWTALL / 'TALLY'    /
  13758.       DATA CWTITL / 'TITLE'    /
  13759.       DATA CWUSIN / 'USING'    /
  13760.       DATA CWWHER / 'WHERE'    /
  13761.       DATA CWWIDT / 'WIDTH'    /
  13762.       DATA CWCHAN / 'CHANGE'   /
  13763.       DATA CWDEFI / 'DEFINE'   /
  13764.       DATA CWDELE / 'DELETE'   /
  13765.       DATA CWDOUB / 'DOUBLE'   /
  13766.       DATA CWMODI / 'MODIFY'   /
  13767.       DATA CWNOEC / 'NOECHO'   /
  13768.       DATA CWOUTP / 'OUTPUT'   /
  13769.       DATA CWRELO / 'RELOAD'   /
  13770.       DATA CWREMO / 'REMOVE'   /
  13771.       DATA CWRENA / 'RENAME'   /
  13772.       DATA CWSELE / 'SELECT'   /
  13773.       DATA CWSORT / 'SORTED'   /
  13774.       DATA CWTUPL / 'TUPLES'   /
  13775.       DATA CWUNLO / 'UNLOAD'   /
  13776.       DATA CWCOMP / 'COMPUTE'  /
  13777.       DATA CWEXHI / 'EXHIBIT'  /
  13778.       DATA CWFORM / 'FORMING'  /
  13779.       DATA CWLIST / 'LISTREL'  /
  13780.       DATA CWNEWP / 'NEWPAGE'  /
  13781.       DATA CWNOCH / 'NOCHECK'  /
  13782.       DATA CWPERC / 'PERCENT'  /
  13783.       DATA CWPROJ / 'PROJECT'  /
  13784.       DATA CWATTR / 'ATTRIBUT' /
  13785.       DATA CWDUPL / 'DUPLICAT' /
  13786.       DATA CWELEM / 'ELEMENTS' /
  13787.       DATA CWINTS / 'INTERSEC' /
  13788.       DATA CWPASS / 'PASSWORD' /
  13789.       DATA CWRELA / 'RELATION' /
  13790.       DATA CWSUBT / 'SUBTRACT' /
  13791.       DATA CWTERM / 'TERMINAL' /
  13792.       DATA CWTOLE / 'TOLERANC' /
  13793. C
  13794. C  SET THE RMATTS VARIABLES
  13795. C
  13796.       KZVEC  = JZVEC
  13797.       KZMAT  = JZMAT
  13798.       KZVAR  = JZVAR
  13799.       KZINT  = JZINT
  13800.       KZREAL = JZREAL
  13801.       KZDOUB = JZDOUB
  13802.       KZTEXT = JZTEXT
  13803.       KZIVEC = JZIVEC
  13804.       KZRVEC = JZRVEC
  13805.       KZDVEC = JZDVEC
  13806.       KZIMAT = JZIMAT
  13807.       KZRMAT = JZRMAT
  13808.       KZDMAT = JZDMAT
  13809. C
  13810. C  SET THE RMKEYW VARIABLES
  13811. C
  13812.       KWBY   = JWBY
  13813.       KWEQ   = JWEQ
  13814.       KWIN   = JWIN
  13815.       KWIS   = JWIS
  13816.       KWTO   = JWTO
  13817.       KWALL  = JWALL
  13818.       KWEND  = JWEND
  13819.       KWFOR  = JWFOR
  13820.       KWINT  = JWINT
  13821.       KWKEY  = JWKEY
  13822.       KWMPW  = JWMPW
  13823.       KWRPW  = JWRPW
  13824.       KWVAR  = JWVAR
  13825.       KWZIP  = JWZIP
  13826.       KWDATE = JWDATE
  13827.       KWDMAT = JWDMAT
  13828.       KWDVEC = JWDVEC
  13829.       KWECHO = JWECHO
  13830.       KWEXIT = JWEXIT
  13831.       KWFROM = JWFROM
  13832.       KWHELP = JWHELP
  13833.       KWIMAT = JWIMAT
  13834.       KWIVEC = JWIVEC
  13835.       KWJOIN = JWJOIN
  13836.       KWLOAD = JWLOAD
  13837.       KWMENU = JWMENU
  13838.       KWOPEN = JWOPEN
  13839.       KWQUIT = JWQUIT
  13840.       KWREAD = JWREAD
  13841.       KWREAL = JWREAL
  13842.       KWRMAT = JWRMAT
  13843.       KWROWS = JWROWS
  13844.       KWRULE = JWRULE
  13845.       KWRVEC = JWRVEC
  13846.       KWTEXT = JWTEXT
  13847.       KWUSER = JWUSER
  13848.       KWWITH = JWWITH
  13849.       KWBLAN = JWBLAN
  13850.  
  13851.       KWBUIL = JWBUIL
  13852.       KWCHEC = JWCHEC
  13853.       KWCLOS = JWCLOS
  13854.       KWCOUN = JWCOUN
  13855.       KWINPU = JWINPU
  13856.       KWLIMI = JWLIMI
  13857.       KWLINE = JWLINE
  13858.       KWOWNE = JWOWNE
  13859.       KWPRIN = JWPRIN
  13860.       KWRULS = JWRULS
  13861.       KWTALL = JWTALL
  13862.       KWTITL = JWTITL
  13863.       KWUSIN = JWUSIN
  13864.       KWWHER = JWWHER
  13865.       KWWIDT = JWWIDT
  13866.       KWCHAN = JWCHAN
  13867.       KWDEFI = JWDEFI
  13868.       KWDELE = JWDELE
  13869.       KWDOUB = JWDOUB
  13870.       KWMODI = JWMODI
  13871.       KWNOEC = JWNOEC
  13872.       KWOUTP = JWOUTP
  13873.       KWRELO = JWRELO
  13874.       KWREMO = JWREMO
  13875.       KWRENA = JWRENA
  13876.       KWSELE = JWSELE
  13877.       KWSORT = JWSORT
  13878.       KWTUPL = JWTUPL
  13879.       KWUNLO = JWUNLO
  13880.       KWCOMP = JWCOMP
  13881.       KWEXHI = JWEXHI
  13882.       KWFORM = JWFORM
  13883.       KWLIST = JWLIST
  13884.       KWNEWP = JWNEWP
  13885.       KWNOCH = JWNOCH
  13886.       KWPERC = JWPERC
  13887.       KWPROJ = JWPROJ
  13888.       KWATTR = JWATTR
  13889.       KWDUPL = JWDUPL
  13890.       KWELEM = JWELEM
  13891.       KWINTS = JWINTS
  13892.       KWPASS = JWPASS
  13893.       KWRELA = JWRELA
  13894.       KWSUBT = JWSUBT
  13895.       KWTERM = JWTERM
  13896.       KWTOLE = JWTOLE
  13897.       RETURN
  13898.       END
  13899.       SUBROUTINE RMCONS
  13900.         Include TEXT.BLK
  13901. C
  13902. C  PURPOSE:  THIS ROUTINE INITIALIZES THE HOLLERITH CONSTANTS USED
  13903. C            BY RIM. THE CODE IS MACHINE DEPENDENT.  IT HAS A SECOND
  13904. C            PART RMCON2 CALLED BY THIS ROUTINE. 
  13905. C
  13906.         Include FLAGS.BLK
  13907.         Include MISC.BLK
  13908.         Include CONST4.BLK
  13909.         Include CONST8.BLK
  13910.       REAL*8  J8RRC,J8RDT,J8NAM,J8NUM,J8AOR,J8AN1,
  13911.      X        J8RN1,J8OPR,J8TYP,J8AN2,J8RN2,J8VAL,J8XXX,J8AND,J8OR,
  13912.      X        J8ZFIL,J8HDB,J8COMM,J8SCH,J8RC,J8DBA,J8RMDT,J8RIM,
  13913.      X        J8BEGI,J8READ,J8USE,J8LOAD,J8DEFI,J8MENU,J8EXIT,J8IN,
  13914.      X        J8OUT,J8LIM,J8ROWS,J8DATA,J8ALL,J8ZZ98,J8ZZ99
  13915.       REAL*8  J8CON1,J8CON2,J8CON3
  13916. C %%%%%%%*******
  13917.       CHARACTER*8  C8RRC,C8RDT,C8NAM,C8NUM,C8AOR,C8AN1,
  13918.      X        C8RN1,C8OPR,C8TYP,C8AN2,C8RN2,C8VAL,C8XXX,C8AND,C8OR,
  13919.      X        C8ZFIL,C8HDB,C8COMM,C8SCH,C8RC,C8DBA,C8RMDT,C8RIM,
  13920.      X        C8BEGI,C8READ,C8USE,C8LOAD,C8DEFI,C8MENU,C8EXIT,C8IN,
  13921.      X        C8OUT,C8LIM,C8ROWS,C8DATA,C8ALL,C8ZZ98,C8ZZ99
  13922.     EQUIVALENCE (C8RRC,J8RRC)
  13923.     EQUIVALENCE (C8RDT,J8RDT)
  13924.     EQUIVALENCE (C8NAM,J8NAM)
  13925.     EQUIVALENCE (C8NUM,J8NUM)
  13926.     EQUIVALENCE (C8AOR,J8AOR)
  13927.     EQUIVALENCE (C8AN1,J8AN1)
  13928.     EQUIVALENCE (C8RN1,J8RN1)
  13929.     EQUIVALENCE (C8OPR,J8OPR)
  13930.     EQUIVALENCE (C8TYP,J8TYP)
  13931.     EQUIVALENCE (C8AN2,J8AN2)
  13932.     EQUIVALENCE (C8RN2,J8RN2)
  13933.     EQUIVALENCE (C8RN2,J8RN2)
  13934.     EQUIVALENCE (C8VAL,J8VAL)
  13935.     EQUIVALENCE (C8XXX,J8XXX)
  13936.     EQUIVALENCE (C8AND,J8AND)
  13937.     EQUIVALENCE (C8OR,J8OR)
  13938.     EQUIVALENCE (C8ZFIL,J8ZFIL)
  13939.     EQUIVALENCE (C8HDB,J8HDB)
  13940.     EQUIVALENCE (C8COMM,J8COMM)
  13941.     EQUIVALENCE (C8SCH,J8SCH)
  13942.     EQUIVALENCE (C8RC,J8RC)
  13943.     EQUIVALENCE (C8DBA,J8DBA)
  13944.     EQUIVALENCE (C8RMDT,J8RMDT)
  13945.     EQUIVALENCE (C8RIM,J8RIM)
  13946.     EQUIVALENCE (C8BEGI,J8BEGI)
  13947.     EQUIVALENCE (C8READ,J8READ)
  13948.     EQUIVALENCE (C8USE,J8USE)
  13949.     EQUIVALENCE (C8LOAD,J8LOAD)
  13950.     EQUIVALENCE (C8DEFI,J8DEFI)
  13951.     EQUIVALENCE (C8MENU,J8MENU)
  13952.     EQUIVALENCE (C8EXIT,J8EXIT)
  13953.     EQUIVALENCE (C8IN,J8IN)
  13954.     EQUIVALENCE (C8OUT,J8OUT)
  13955.     EQUIVALENCE (C8LIM,J8LIM)
  13956.     EQUIVALENCE (C8ROWS,J8ROWS)
  13957.     EQUIVALENCE (C8DATA,J8DATA)
  13958.     EQUIVALENCE (C8ALL,J8ALL)
  13959.     EQUIVALENCE (C8ZZ98,J8ZZ98)
  13960.     EQUIVALENCE (C8ZZ99,J8ZZ99)
  13961. C ***
  13962.       CHARACTER*8  C8CON1,C8CON2,C8CON3
  13963.     EQUIVALENCE (C8CON1,J8CON1)
  13964.     EQUIVALENCE (C8CON2,J8CON2)
  13965.     EQUIVALENCE (C8CON3,J8CON3)
  13966. C
  13967.       DIMENSION J4KOM(6),J4BOOL(17),J4HEAD(6)
  13968.     CHARACTER*4 C4KOM(6),C4BOOL(17),C4HEAD(6)
  13969.     EQUIVALENCE(J4KOM(1),C4KOM(1))
  13970.     EQUIVALENCE (J4BOOL(1),C4BOOL(1))
  13971.     EQUIVALENCE (J4HEAD(1),C4HEAD(1))
  13972.     CHARACTER*4 J4CON1,J4CON2,J4CON3,J4CON4
  13973.     CHARACTER*4 J4DP,J4RP,J4LP,J4HP,J4IS,J4EQ,J4ON
  13974.     CHARACTER*4 J4OR,J4OFF,J4AND,J4MIN,J4MAX
  13975.     CHARACTER*4 J4AVE,J4SUM,J4END,J4DIM,J4CRE,J4UPD,J4EOF
  13976.     CHARACTER*4 J4LOD,J4QUE,J4COM,J4CON,J4KEY,J4YES,J4FOR
  13977.     CHARACTER*4 J4LOA,J4QUIT,J4EXIT
  13978.     CHARACTER*4 J4ECHO,J4LOAD,J4DATA,J4NONE,J4PROM,J4PRES,J4INPT
  13979.     CHARACTER*4 J4OTPT,J4WITH,J4HASH,J4A,J4D
  13980.     CHARACTER*4 J4Y,J4N,J4E,J4M,J40,J41,J42,J43,J44,J45
  13981.     CHARACTER*4 J46,J47,J48,J49
  13982.     CHARACTER*4 J4DOT,J4COL,J4EQS,J4STAR,J4QUOT,J4COMA
  13983.     CHARACTER*4 J4LPAR,J4RPAR,J4PLUS,J4MNUS
  13984. C
  13985. C  VARIABLES USED BY THE FLAGS AND MISC COMMON BLOCKS
  13986. C
  13987.       DATA C8CON1 /'NONE'/
  13988.       DATA C8CON2 /' '/
  13989.       DATA C8CON3 /'-0-'/
  13990.       DATA J4CON1 /' '/
  13991.       DATA J4CON2 /'RIM'/
  13992.       DATA J4CON3 /'-0-'/
  13993.       DATA J4CON4 /'*END'/
  13994. C
  13995. C  VARIABLES USED BY THE CONST4 COMMON BLOCK
  13996. C
  13997.       DATA J4DP /'D>'/
  13998.       DATA J4RP /'R>'/
  13999.       DATA J4LP /'L>'/
  14000.       DATA J4HP /'H>'/
  14001.       DATA J4IS /'IS'/
  14002.       DATA J4EQ /'EQ'/
  14003.       DATA J4ON /'ON'/
  14004.       DATA J4OR /'OR'/
  14005.       DATA J4OFF /'OFF'/
  14006.       DATA J4AND /'AND'/
  14007.       DATA J4MIN /'MIN'/
  14008.       DATA J4MAX /'MAX'/
  14009.       DATA J4AVE /'AVE'/
  14010.       DATA J4SUM /'SUM'/
  14011.       DATA J4END /'END'/
  14012.       DATA J4DIM /'DIM'/
  14013.       DATA J4CRE /'CRE'/
  14014.       DATA J4UPD /'UPD'/
  14015.       DATA J4EOF /'EOF'/
  14016.       DATA J4LOD /'LOD'/
  14017.       DATA J4QUE /'QUE'/
  14018.       DATA J4COM /'COM'/
  14019.       DATA J4CON /'CON'/
  14020.       DATA J4KEY /'KEY'/
  14021.       DATA J4YES /'YES'/
  14022.       DATA J4FOR /'FOR'/
  14023.       DATA J4LOA /'LOA'/
  14024.       DATA J4QUIT /'QUIT'/
  14025.       DATA J4EXIT /'EXIT'/
  14026.       DATA J4ECHO /'ECHO'/
  14027.       DATA J4LOAD /'LOAD'/
  14028.       DATA J4DATA /'DATA'/
  14029.       DATA J4NONE /'NONE'/
  14030.       DATA J4PROM /'PROM'/
  14031.       DATA J4PRES /'PRES'/
  14032.       DATA J4INPT /'INPT'/
  14033.       DATA J4OTPT /'OTPT'/
  14034.       DATA J4WITH /'WITH'/
  14035.       DATA J4HASH /'HASH'/
  14036.       DATA J4A /'A'/
  14037.       DATA J4D /'D'/
  14038.       DATA J4Y /'Y'/
  14039.       DATA J4N /'N'/
  14040.       DATA J4E /'E'/
  14041.       DATA J4M /'M'/
  14042.       DATA J40 /'0'/
  14043.       DATA J41 /'1'/
  14044.       DATA J42 /'2'/
  14045.       DATA J43 /'3'/
  14046.       DATA J44 /'4'/
  14047.       DATA J45 /'5'/
  14048.       DATA J46 /'6'/
  14049.       DATA J47 /'7'/
  14050.       DATA J48 /'8'/
  14051.       DATA J49 /'9'/
  14052.       DATA J4DOT /'.'/
  14053.       DATA J4COL /':'/
  14054.       DATA J4EQS /'='/
  14055.       DATA J4STAR /'*'/
  14056.       DATA J4QUOT /'"'/
  14057.       DATA J4COMA /','/
  14058.       DATA J4LPAR /'('/
  14059.       DATA J4RPAR /')'/
  14060.       DATA J4PLUS /'+'/
  14061.       DATA J4MNUS /'-'/
  14062.       DATA C4KOM /'EQ','EQ','GE','GT','LE','LT'/
  14063.       DATA C4BOOL /'EXI','EQ','NE','GT','GE','LT','LE',
  14064.      X             'FAI','EQS','\0','\0',
  14065.      X             'EQA','NEA','GTA','GEA','LTA','LEA'/
  14066.       DATA C4HEAD /'NUMB','ER O','F OC','CURR','ENCE','S   '/
  14067. C
  14068. C  VARIABLES USED BY THE CONST8 COMMON BLOCK
  14069. C
  14070.       DATA C8RRC /'RMRULRRC'/
  14071.       DATA C8RDT /'RMRULRDT'/
  14072.       DATA C8NAM /'RMRULNAM'/
  14073.       DATA C8NUM /'RMRULNUM'/
  14074.       DATA C8AOR /'RMRULAOR'/
  14075.       DATA C8AN1 /'RMRULAN1'/
  14076.       DATA C8RN1 /'RMRULRN1'/
  14077.       DATA C8OPR /'RMRULOPR'/
  14078.       DATA C8TYP /'RMRULTYP'/
  14079.       DATA C8AN2 /'RMRULAN2'/
  14080.       DATA C8RN2 /'RMRULRN2'/
  14081.       DATA C8VAL /'RMRULVAL'/
  14082.       DATA C8XXX /'ASDFGHJK'/
  14083.       DATA C8AND /'AND'/
  14084.       DATA C8OR   /'OR'/
  14085.       DATA C8ZFIL /'ZZRIMZZ'/
  14086.       DATA C8HDB  /'HELPDB'/
  14087.       DATA C8COMM /'COMMAND'/
  14088.       DATA C8SCH  /'SCHEMA'/
  14089.       DATA C8RC   /' ROW COL'/
  14090.       DATA C8DBA  /'RIMDBA'/
  14091.       DATA C8RMDT /'RIMDATA'/
  14092.       DATA C8RIM  /'RIM'/
  14093.       DATA C8BEGI /'BEGIN'/
  14094.       DATA C8READ /'READ'/
  14095.       DATA C8USE  /'USE'/
  14096.       DATA C8LOAD /'LOAD'/
  14097.       DATA C8DEFI /'DEFINE'/
  14098.       DATA C8MENU /'MENU'/
  14099.       DATA C8EXIT /'EXIT'/
  14100.       DATA C8IN   /'INPUT'/
  14101.       DATA C8OUT  /'OUTPUT'/
  14102.       DATA C8LIM  /'LIMIT'/
  14103.       DATA C8ROWS /'ROWS'/
  14104.       DATA C8DATA /'DATA'/
  14105.       DATA C8ALL  /'ALL'/
  14106.       DATA C8ZZ98 /'ZZ98'/
  14107.       DATA C8ZZ99 /'ZZ99'/
  14108. C
  14109. C  SET THE FLAGS AND MISC VARIABLES
  14110. C
  14111.       USERID = J8CON1
  14112.       NONE = J8CON1
  14113.       BLANK = J8CON2
  14114.       DBNAME = J8CON3
  14115.       IBLANK = J4CON1
  14116.       LSTCMD = J4CON2
  14117.       NULL = J4CON3
  14118.       ENDWRD = J4CON4
  14119.       DFLAG = .FALSE.
  14120. C
  14121. C  SET THE CONST4 VARIABLES
  14122. C
  14123.       K4DP   = J4DP
  14124.       K4RP   = J4RP
  14125.       K4LP   = J4LP
  14126.       K4HP   = J4HP
  14127.       K4IS   = J4IS
  14128.       K4EQ   = J4EQ
  14129.       K4ON   = J4ON
  14130.       K4OR   = J4OR
  14131.       K4OFF  = J4OFF
  14132.       K4AND  = J4AND
  14133.       K4MIN  = J4MIN
  14134.       K4MAX  = J4MAX
  14135.       K4AVE  = J4AVE
  14136.       K4SUM  = J4SUM
  14137.       K4END  = J4END
  14138.       K4DIM  = J4DIM
  14139.       K4CRE  = J4CRE
  14140.       K4UPD  = J4UPD
  14141.       K4EOF  = J4EOF
  14142.       K4LOD  = J4LOD
  14143.       K4QUE  = J4QUE
  14144.       K4COM  = J4COM
  14145.       K4CON  = J4CON
  14146.       K4KEY  = J4KEY
  14147.       K4YES  = J4YES
  14148.       K4FOR  = J4FOR
  14149.       K4LOA  = J4LOA
  14150.       K4QUIT = J4QUIT
  14151.       K4EXIT = J4EXIT
  14152.       K4ECHO = J4ECHO
  14153.       K4LOAD = J4LOAD
  14154.       K4DATA = J4DATA
  14155.       K4NONE = J4NONE
  14156.       K4PROM = J4PROM
  14157.       K4PRES = J4PRES
  14158.       K4INPT = J4INPT
  14159.       K4OTPT = J4OTPT
  14160.       K4WITH = J4WITH
  14161.       K4HASH = J4HASH
  14162.       K4A    = J4A
  14163.       K4D    = J4D
  14164.       K4Y    = J4Y
  14165.       K4N    = J4N
  14166.       K4E    = J4E
  14167.       K4M    = J4M
  14168.       K40    = J40
  14169.       K41    = J41
  14170.       K42    = J42
  14171.       K43    = J43
  14172.       K44    = J44
  14173.       K45    = J45
  14174.       K46    = J46
  14175.       K47    = J47
  14176.       K48    = J48
  14177.       K49    = J49
  14178.       K4DOT  = J4DOT
  14179.       K4COL  = J4COL
  14180.       K4EQS  = J4EQS
  14181.       K4STAR = J4STAR
  14182.       K4QUOT = J4QUOT
  14183.       K4COMA = J4COMA
  14184.       K4LPAR = J4LPAR
  14185.       K4RPAR = J4RPAR
  14186.       K4PLUS = J4PLUS
  14187.       K4MNUS = J4MNUS
  14188.       DO 100 K = 1,6
  14189.       K4KOM(K) = J4KOM(K)
  14190.       K4HEAD(K) = J4HEAD(K)
  14191.   100 CONTINUE
  14192.       DO 200 K = 1,17
  14193.       K4BOOL(K) = J4BOOL(K)
  14194.   200 CONTINUE
  14195. C
  14196. C  SET THE CONST8 VARIABLES
  14197. C
  14198.       K8RRC  = J8RRC
  14199.       K8RDT  = J8RDT
  14200.       K8NAM  = J8NAM
  14201.       K8NUM  = J8NUM
  14202.       K8AOR  = J8AOR
  14203.       K8AN1  = J8AN1
  14204.       K8RN1  = J8RN1
  14205.       K8OPR  = J8OPR
  14206.       K8TYP  = J8TYP
  14207.       K8AN2  = J8AN2
  14208.       K8RN2  = J8RN2
  14209.       K8VAL  = J8VAL
  14210.       K8XXX  = J8XXX
  14211.       K8AND  = J8AND
  14212.       K8OR   = J8OR
  14213.       K8ZFIL = J8ZFIL
  14214.       K8HDB  = J8HDB
  14215.       K8COMM = J8COMM
  14216.       K8SCH  = J8SCH
  14217.       K8RC   = J8RC
  14218.       K8DBA  = J8DBA
  14219.       K8RMDT = J8RMDT
  14220.       K8RIM  = J8RIM
  14221.       K8BEGI = J8BEGI
  14222.       K8READ = J8READ
  14223.       K8USE  = J8USE
  14224.       K8LOAD = J8LOAD
  14225.       K8DEFI = J8DEFI
  14226.       K8MENU = J8MENU
  14227.       K8EXIT = J8EXIT
  14228.       K8IN   = J8IN
  14229.       K8OUT  = J8OUT
  14230.       K8LIM  = J8LIM
  14231.       K8ROWS = J8ROWS
  14232.       K8DATA = J8DATA
  14233.       K8ALL  = J8ALL
  14234.       K8ZZ98 = J8ZZ98
  14235.       K8ZZ99 = J8ZZ99
  14236. C***************
  14237.       CALL RMCON2
  14238.       RETURN
  14239.       END
  14240.       SUBROUTINE RMDATE(IT)
  14241.         Include TEXT.BLK
  14242. C
  14243. C  PURPOSE:   RETURN THE CURRENT DATE IN YY/MM/DD FORMAT
  14244. C
  14245. C  PARAMETERS:
  14246. C         IT------THE CURRENT DATE
  14247. C
  14248.         Include MISC.BLK
  14249.       INTEGER MONTH,DAY,YEAR
  14250.       REAL*8 IT
  14251.       CHARACTER*1 SLASH
  14252.       DATA SLASH /'/'/
  14253. C ZERO M,D,Y CELLS SINCE IDATE ONLY MODIFIES LOW 16 BITS
  14254.     MONTH=0
  14255.     DAY=0
  14256.     YEAR=0
  14257. C      CALL IDATE(MONTH,DAY,YEAR)
  14258. C MODIFY CALL FOR MSDOS. VAX GETS CALL COMMENTED OUT ABOVE, AS DOES PDP11
  14259.       CALL DATE(MONTH, DAY,YEAR)
  14260. C    YEAR=YEAR-1900
  14261. C ADJUST FOR IDATE RETURNING 1985, NOT JUST 85.
  14262.       IF(MONTH.LT.10) MONTH = MONTH + 100
  14263.       IF(DAY.LT.10) DAY = DAY + 100
  14264.       CALL ITOC(IT,1,2,YEAR,IERR)
  14265.       CALL ITOC(IT,3,3,MONTH,IERR)
  14266.       CALL ITOC(IT,6,3,DAY,IERR)
  14267.       CALL PUTT(IT,3,SLASH)
  14268.       CALL PUTT(IT,6,SLASH)
  14269.       RETURN
  14270.       END
  14271.       SUBROUTINE RMDBGT(NAMDB,DBSTAT)
  14272.         Include TEXT.BLK
  14273. C
  14274. C  PURPOSE: THIS ROUTINE WILL GET A RIM DATA BASE FROM PERMANENT
  14275. C           FILE. THE DATA BASE MAY BE DIRECT OR INDIRECT AND MAY
  14276. C           RESIDE ON AN ALTERNATE ACCOUNT. THIS ROUTINE HAS TWO
  14277. C           SECTIONS - AN MENU MODE SECTION WHERE THE DATA BASE
  14278. C           FILE DATA IS REQUESTED FROM THE USER, A COMMAND MODE SECTION
  14279. C           WHERE THE "OPEN DBNAME ....." COMMAND IS PROCESSED TO GET
  14280. C           THE FILE DATA.
  14281. C
  14282. C  SYSTEM: CDC CYBER (BOEING)
  14283. C
  14284. C  PARAMETERS: NAMDB -- DATABASE NAME IN H FORMAT ('DBNAME')
  14285. C              DBSTAT - 0 IF SUCCESSFULL DATABASE RETRIEVAL
  14286. C                       1 IF UNSUCCESSFULL
  14287. C                       2 IF "QUIT"
  14288. C
  14289.       INTEGER DBSTAT
  14290.       DBSTAT = 0
  14291.       RETURN
  14292.       END
  14293.       SUBROUTINE RMDBLK(NAMDB)
  14294.         Include TEXT.BLK
  14295. C
  14296. C  PURPOSE: THIS ROUTINE CHECKS FOR MODIFY PERMISSION ON A GIVEN
  14297. C           DATABASE FILE. CHECKS FOR WRITE MODE ON DIRECT ACCESS
  14298. C           AND CHECKS THE LOCKING FILE FOR INDIRQECT ACCESS FILES.
  14299. C
  14300. C  SYSTEM:  CDC CYBER (BOEING)
  14301. C
  14302. C  PARAMETERS: NAMDB -- DATABASE NAME IN H FORMAT
  14303. C
  14304.         Include RIMCOM.BLK
  14305.       RMSTAT = 0
  14306.       RETURN
  14307.       END
  14308.       SUBROUTINE RMDBPT
  14309.         Include TEXT.BLK
  14310. C
  14311. C  PURPOSE: THIS ROUTINE RETURNS THE RIM DATABASES THAT HAVE BEEN
  14312. C           MODIFIED. THE ROUTINE IS DUMMY FOR DIRECT ACCESS
  14313. C           DATABASES, USER MANAGED DATABASES AND DATABASES THAT
  14314. C           HAVE NOT BEEN MODIFIED. NEW DATABASE (DEFINE) MAY BE
  14315. C           SAVED AS INDIRECT OR DIRECT ACCESS FILES (PRIVATE).
  14316. C
  14317. C  SYSTEM: CDC CYBER (BOEING)
  14318. C
  14319. C  PARAMETERS: NONE
  14320. C
  14321.       RETURN
  14322.       END
  14323.       SUBROUTINE RMDEL(INDPTR)
  14324.         Include TEXT.BLK
  14325. C
  14326. C  THIS ROUTINE DELETES THE CURRENT ROW.
  14327. C
  14328. C  PARAMETERS:
  14329. C         INDPTR--INDEX TO SAVE BLOCK (RANGE OF 0 TO 9)
  14330.         Include KEYDAT.BLK
  14331.         Include RIMCOM.BLK
  14332.         Include MISC.BLK
  14333.         Include FLAGS.BLK
  14334.         Include TUPLER.BLK
  14335.         Include TUPLEA.BLK
  14336.         Include RIMPTR.BLK
  14337.         Include BUFFER.BLK
  14338.         Include START.BLK
  14339.       INTEGER COLUMN
  14340.       RMSTAT = 0
  14341. C
  14342. C         MAKE SURE DB IS DEFINED
  14343. C
  14344.       IF(DFLAG) GOTO 10
  14345.       RMSTAT = 16
  14346.       GOTO 9999
  14347. C
  14348.    10 CONTINUE
  14349. C
  14350. C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
  14351. C
  14352.       CALL RMDBLK(DBNAME)
  14353.       IF(RMSTAT.NE.0) GO TO 9999
  14354. C
  14355. C  RESTORE THE BLOCKS AS NEEDED.
  14356. C
  14357.       CALL RMRES(INDPTR)
  14358.       IF(RMSTAT.NE.0) GO TO 9999
  14359. C
  14360. C  CHECK FOR WRITE PERMISSION ON THIS RELATION.
  14361. C
  14362.       I = LOCPRM(NAME,2)
  14363.       IF(RMSTAT.NE.0) GO TO 9999
  14364. C
  14365. C  CHECK THAT RMGET WAS CALLED
  14366. C
  14367.       IF((IVAL.GT.0).AND.(IVAL.LT.ALL9S)) GO TO 200
  14368. C
  14369. C  RMGET WAS NOT CALLED BEFORE RMPUT
  14370. C
  14371.       RMSTAT = 60
  14372.       GO TO 9999
  14373. C
  14374. C  RETRIEVE THE CURRENT ROW IN A SCRATCH TUPLE.
  14375. C
  14376.   200 CONTINUE
  14377.       CALL BLKCHG(11,MAXCOL,1)
  14378.       KQ1 = BLKLOC(11)
  14379.       NID = CID
  14380.       INDEX = INDPTR
  14381.       IF(INDEX.EQ.0) INDEX = 1
  14382.       IF(INDEX.GT.3) INDEX = 3
  14383.       LNS = NS
  14384.       NS = 0
  14385.       CALL RMLOOK(BUFFER(KQ1),INDEX,0,KURLEN)
  14386.       IVAL = IVAL - 1
  14387.       NS = LNS
  14388.       IF(RMSTAT.EQ.0) GO TO 300
  14389. C
  14390. C  NO DATA AVAILABLE
  14391. C
  14392.       RMSTAT = 60
  14393.       GO TO 9999
  14394. C
  14395. C  DELETE THE CURRENT ROW OF THE RELATION.
  14396. C
  14397.   300 CONTINUE
  14398.       CALL DELDAT(INDEX,CID)
  14399.       RDATE = DBDATE
  14400.       NTUPLE = NTUPLE - 1
  14401.       CALL RELPUT
  14402. C
  14403. C  CHANGE THE POINTERS FOR ANY KEY ELEMENTS.
  14404. C
  14405.       IF(NUMKEY.EQ.0) GO TO 9999
  14406.       I = 0
  14407.       IF(NUMKEY.LE.5) GO TO 380
  14408.       I = LOCATT(BLANK,NAME)
  14409.   380 CONTINUE
  14410.       IF(NUMKEY.GT.5) GO TO 390
  14411.       I = I + 1
  14412.       IF(I.GT.NUMKEY) GO TO 9999
  14413.       START = KEYDAT(1,I)
  14414.       COLUMN = KEYDAT(2,I)
  14415.       ATTWDS = KEYDAT(3,I)
  14416.       ATTYPE = KEYDAT(4,I)
  14417.       GO TO 395
  14418.   390 CONTINUE
  14419.       CALL ATTGET(ISTAT)
  14420.       IF(ISTAT.NE.0) GO TO 9999
  14421.       IF(ATTKEY.EQ.0) GO TO 380
  14422.       START = ATTKEY
  14423.       COLUMN = ATTCOL
  14424.   395 CONTINUE
  14425.       IF(ATTWDS.NE.0) GO TO 400
  14426.       COLUMN = BUFFER(KQ1+COLUMN-1) + 2
  14427.   400 CONTINUE
  14428.       IF(BUFFER(KQ1+COLUMN-1).EQ.NULL) GO TO 380
  14429.       CALL BTREP(BUFFER(KQ1+COLUMN-1),0,CID,ATTYPE)
  14430.       GO TO 380
  14431.  9999 CONTINUE
  14432.       RETURN
  14433.       END
  14434.       SUBROUTINE RMFIND(INDPTR,RNAME)
  14435.         Include TEXT.BLK
  14436. C
  14437. C  PURPOSE: LOCATE THE TUPLES FOR RELATION RNAME
  14438. C
  14439. C  PARAMETERS: INDPTR--MULTIPLE RELATION POSITION INDICATOR
  14440. C              RNAME---RELATION NAME
  14441. C
  14442.         Include FLAGS.BLK
  14443.         Include TUPLER.BLK
  14444.         Include TUPLEA.BLK
  14445.         Include VARDAT.BLK
  14446.         Include KEYDAT.BLK
  14447.         Include RIMCOM.BLK
  14448.         Include RIMPTR.BLK
  14449.         Include MISC.BLK
  14450.         Include PTRCOM.BLK
  14451.         Include RULCOM.BLK
  14452.         Include WHCOM.BLK
  14453. C
  14454.       LOGICAL EQ
  14455.         Include DCLAR1.BLK
  14456. C
  14457. C  INITIALIZE
  14458. C
  14459.       RMSTAT = 0
  14460. C         MAKE SURE DB IS DEFINED
  14461. C
  14462.       IF(DFLAG) GOTO 10
  14463.       RMSTAT = 16
  14464.       GOTO 999
  14465. C
  14466.    10 CONTINUE
  14467.       IF(INDCUR.NE.NULL) GO TO 50
  14468. C
  14469. C     FIRST TIME IN - CHECK INDPTR
  14470. C
  14471.       IF((INDPTR.GE.0).AND.(INDPTR.LE.9)) GO TO 100
  14472.       RMSTAT = 70
  14473.       GO TO 999
  14474.    50 CONTINUE
  14475. C
  14476. C  SAVE THE CURRENT POINTERS
  14477. C
  14478.       IF(INDCUR.NE.INDPTR) CALL RMSAV(INDCUR)
  14479.       IF(RMSTAT.NE.0) GO TO 999
  14480. C
  14481. C  CHECK FOR RULES FOR THIS RELATION
  14482. C
  14483.   100 RULES = .FALSE.
  14484.       I = LOCREL(RIMRRC)
  14485.       IF(I.NE.0) GO TO 140
  14486.       CALL CHKRUL(RNAME)
  14487.       IF(RMSTAT.GE.110) GO TO 999
  14488.       RMSTAT = 0
  14489. C
  14490. C  LOCATE THE RELATION
  14491. C
  14492.   140 CONTINUE
  14493.       I = LOCREL(RNAME)
  14494.       IF(I.NE.0) GO TO 150
  14495.       CALL RELGET(I)
  14496.       IF(I.EQ.0) GO TO 200
  14497.   150 CONTINUE
  14498.       RMSTAT = 20
  14499.       GO TO 999
  14500. C
  14501. C  SET CURRENT BLOCK AND CHECK READ PERMISSION
  14502. C
  14503.   200 INDCUR = INDPTR
  14504.       NS = 0
  14505.       IF(EQ(USERID,OWNER)) GO TO 300
  14506.       IF(EQ(RPW,NONE)) GO TO 300
  14507.       IF(EQ(RPW,USERID)) GO TO 300
  14508.       IF(EQ(MPW,USERID)) GO TO 300
  14509.       RMSTAT = 90
  14510.       GO TO 999
  14511.   300 CONTINUE
  14512. C
  14513. C  SET NUMBER OF WHERE CONDITIONS AND TUPLE LIMIT
  14514. C
  14515.       NBOO = 0
  14516.       LIMTU = ALL9S
  14517.       MAXGET(INDPTR+1) = NTUPLE
  14518. C
  14519. C  CHECK FOR VARIABLE LENGTH ATTRIBUTES
  14520. C
  14521.       NUMVAR = 0
  14522.       NUMKEY = 0
  14523.       I = LOCATT(BLANK,RNAME)
  14524.       DO 500 J=1,NATT
  14525.       CALL ATTGET(ISTATX)
  14526.       IF(ISTATX.NE.0) GO TO 999
  14527.       IF(ATTKEY.EQ.0) GO TO 400
  14528.       NUMKEY = NUMKEY + 1
  14529.       IF(NUMKEY.GT.5) GO TO 400
  14530.       KEYDAT(1,NUMKEY) = ATTKEY
  14531.       KEYDAT(2,NUMKEY) = ATTCOL
  14532.       KEYDAT(3,NUMKEY) = ATTWDS
  14533.       KEYDAT(4,NUMKEY) = ATTYPE
  14534.       CALL BLKMOV(KEYDAT(5,NUMKEY),ATTNAM,2)
  14535.   400 CONTINUE
  14536.       IF(ATTWDS.NE.0) GO TO 500
  14537.       NUMVAR = NUMVAR + 1
  14538.       IF(NUMVAR.GT.5) GO TO 500
  14539.       POSVAR(1,NUMVAR) = ATTCOL
  14540.       POSVAR(2,NUMVAR) = ATTYPE
  14541.   500 CONTINUE
  14542. C
  14543.   999 CONTINUE
  14544.       RETURN
  14545.       END
  14546.       SUBROUTINE RMGATT(ANAME,TYPE,MATVEC,VAR,LEN1,LEN2,COL,KEY)
  14547.         Include TEXT.BLK
  14548. C
  14549. C  PURPOSE: THIS ROUTINE GETS THE DATA FOR THE CURRENT ATTRIBUTE
  14550. C           FOR THE CURRENT RELATION.
  14551. C           (FORTRAN INTERFACE COVER ROUTINE FOR GETATT)
  14552. C
  14553. C  PARAMETERS: ANAME---ATTRIBUTE NAME
  14554. C              TYPE----ATTRIBUTE TYPE - INT,REAL,TEXT,DOUB
  14555. C              MATVEC--ATTRIBUTE TYPE - MAT OR VEC (OTHERWISE BLANK)
  14556. C              VAR-----VARIABLE LENGTH ATTRIBUTE - .TRUE. OR .FALSE.
  14557. C              LEN1----ATTRIBUTE LENGTH DATA
  14558. C                      TEXT = NUMBER OF CHARACTERS
  14559. C                      INT,REAL,DOUBLE,VECTORS = NUMBER OF ITEMS
  14560. C                      MATRIX = ROW DIMENSION
  14561. C              LEN2----COLUMN DIMENSION OF MATRICES OR 0
  14562. C              COL-----ATTRIBUTE COLUMN IN THE RELATION
  14563. C              KEY-----KEYED ATTRIBUTE - .TRUE. OR .FALSE.
  14564. C
  14565.         Include RIMPTR.BLK
  14566.         Include RMATTS.BLK
  14567.         Include RIMCOM.BLK
  14568.         Include FLAGS.BLK
  14569.         Include TUPLER.BLK
  14570.         Include TUPLEA.BLK
  14571.         Include MISC.BLK
  14572.       INTEGER STATUS
  14573.       LOGICAL EQ
  14574.       INTEGER TYPE
  14575.       INTEGER MATVEC
  14576.       INTEGER LEN1,LEN2
  14577.       INTEGER COL
  14578.       LOGICAL VAR
  14579.       LOGICAL KEY
  14580.         Include DCLAR1.BLK
  14581. C
  14582.       RMSTAT = 0
  14583.       INDCUR = NULL
  14584. C
  14585. C         MAKE SURE DB IS DEFINED
  14586. C
  14587.       IF(DFLAG) GOTO 10
  14588.       RMSTAT = 16
  14589.       GOTO 999
  14590. C
  14591.    10 CONTINUE
  14592.       CALL ATTGET(STATUS)
  14593.       IF(STATUS.EQ.0) GO TO 200
  14594. C
  14595. C  NO MORE ATTRIBUTES
  14596. C
  14597.       RMSTAT = -1
  14598.       GO TO 999
  14599. C
  14600. C   VALIDATE USER
  14601. C
  14602.   200 CONTINUE
  14603.       IF(EQ(USERID,OWNER)) GO TO 300
  14604.       IF(EQ(RPW,NONE)) GO TO 300
  14605.       IF(EQ(RPW,USERID)) GO TO 300
  14606.       IF(EQ(MPW,USERID)) GO TO 300
  14607.       RMSTAT = 90
  14608.       GO TO 999
  14609. C
  14610. C  TRANSFER THE ATTRIBUTE DATA TO THE PROPER ARGUMENTS
  14611. C
  14612.   300 CONTINUE
  14613.       ANAME = ATTNAM
  14614.       CALL TYPER(ATTYPE,MATVEC,TYPE)
  14615.       LEN1 = ATTWDS
  14616.       LEN2 = 0
  14617.       IF(TYPE.EQ.KZTEXT) LEN1 = ATTCHA
  14618.       IF(TYPE.EQ.KZDOUB) LEN1 = LEN1/2
  14619.       IF(MATVEC.NE.KZMAT) GO TO 400
  14620.       LEN2 = LEN1/ATTCHA
  14621.       IF(LEN1.NE.0) LEN1 = ATTCHA
  14622.   400 CONTINUE
  14623.       VAR = .FALSE.
  14624.       IF(LEN1.EQ.0) VAR = .TRUE.
  14625.       KEY = .FALSE.
  14626.       IF(ATTKEY.NE.0) KEY = .TRUE.
  14627.       COL = ATTCOL
  14628.   999 RETURN
  14629.       END
  14630.       SUBROUTINE RMGET(INDPTR,TUPLE)
  14631.         Include TEXT.BLK
  14632. C
  14633. C  THIS ROUTINE GETS THE NEXT ROW FROM A RELATION AND STORES
  14634. C  IT IN TUPLE.
  14635. C
  14636. C  PARAMETERS:
  14637. C         INDPTR--INDEX TO SAVE BLOCK (RANGE OF 0 TO 9)
  14638. C         TUPLE---USER ARRAY TO HOLD ONE COMPLETE TUPLE
  14639.         Include RIMCOM.BLK
  14640.         Include VARDAT.BLK
  14641.         Include PTRCOM.BLK
  14642.         Include RIMPTR.BLK
  14643.         Include BUFFER.BLK
  14644.         Include TUPLER.BLK
  14645.         Include FLAGS.BLK
  14646.         Include MISC.BLK
  14647. C
  14648.       INTEGER TUPLE(1)
  14649.       RMSTAT = 0
  14650. C         MAKE SURE DB IS DEFINED
  14651. C
  14652.       IF(DFLAG) GOTO 10
  14653.       RMSTAT = 16
  14654.       GOTO 9999
  14655. C
  14656.    10 CONTINUE
  14657. C
  14658. C  RESTORE THE BLOCKS AS NEEDED.
  14659. C
  14660.       CALL RMRES(INDPTR)
  14661.       IF(RMSTAT.NE.0) GO TO 9999
  14662. C
  14663. C  LOCATE THE NEXT ROW.
  14664. C
  14665.       INDEX = INDPTR
  14666.       IF(INDEX.EQ.0) INDEX = 1
  14667.       IF(INDEX.GT.3) INDEX = 3
  14668.       IF(NS.EQ.1) GO TO 50
  14669. C
  14670. C  UNSORTED RETRIEVAL
  14671. C
  14672.       CALL RMLOOK(MAT,INDEX,1,LENGTH)
  14673.       IF(IVAL.GT.MAXGET(INDPTR+1)) GO TO 75
  14674.       IF(RMSTAT.EQ.0) GO TO 100
  14675. C
  14676. C  END OF DATA.
  14677. C
  14678.       GO TO 75
  14679. C
  14680. C  SORTED RETRIEVAL
  14681. C
  14682.    50 CONTINUE
  14683.       LENGTH = NCOL + 1
  14684.       CALL RMGTSO(MAT,10,1,LENGTH,INDPTR)
  14685.       CID = BUFFER(MAT)
  14686.       MAT = MAT + 1
  14687.       LENGTH = LENGTH - 1
  14688.       IF(RMSTAT.EQ.0) GO TO 100
  14689. C
  14690. C  END OF DATA
  14691. C
  14692.    75 CONTINUE
  14693.       RMSTAT = -1
  14694.       IVAL = ALL9S
  14695.       GO TO 9999
  14696. C
  14697. C  MOVE THE DATA.
  14698. C
  14699.   100 CONTINUE
  14700.       CALL BLKMOV(TUPLE,BUFFER(MAT),LENGTH)
  14701.       IF(NUMVAR.EQ.0) GO TO 9999
  14702.       CALL RMVARC(-1,TUPLE)
  14703.  9999 CONTINUE
  14704.       RETURN
  14705.       END
  14706.       SUBROUTINE RMGREL(RNAME,LRPW,LMPW,LASTMD,NUMATT,NUMTUP)
  14707.         Include TEXT.BLK
  14708. C
  14709. C  PURPOSE: THIS ROUTINE GETS THE DATA FOR THE CURRENT RELATION
  14710. C           (FORTRAN INTERFACE COVER ROUTINE FOR GETREL)
  14711. C
  14712. C  PARAMETERS: RNAME---RELATION NAME
  14713. C              RPW-----RELATION READ PASSWORD - .TRUE. OR .FALSE.
  14714. C              MPW-----RELATION MODIFY PASSWORD - .TRUE. OR .FALSE.
  14715. C              LASTMD--DATE OF LAST RELATION MODIFICATION
  14716. C              NUMATT--NUMBER OF ATTRIBUTES
  14717. C              NUMTUP--NUMBER OF CURRENTLY DEFINED TUPLES (ROWS)
  14718. C
  14719.         Include RIMCOM.BLK
  14720.         Include FLAGS.BLK
  14721.         Include CONST8.BLK
  14722.         Include RIMPTR.BLK
  14723.         Include TUPLER.BLK
  14724.         Include MISC.BLK
  14725.       INTEGER STATUS
  14726.       INTEGER NUMATT
  14727.       INTEGER NUMTUP
  14728.       LOGICAL LRPW
  14729.       LOGICAL LMPW
  14730.       LOGICAL EQ
  14731.         Include DCLAR1.BLK
  14732.         Include DCLAR6.BLK
  14733. C
  14734.       RMSTAT = 0
  14735.       INDCUR = NULL
  14736.  
  14737. C
  14738. C         MAKE SURE DB IS DEFINED
  14739. C
  14740.       IF(DFLAG) GOTO 10
  14741.       RMSTAT = 16
  14742.       GOTO 999
  14743. C
  14744.    10 CONTINUE
  14745.   100 CONTINUE
  14746.       CALL RELGET(STATUS)
  14747.       IF(STATUS.EQ.0) GO TO 200
  14748. C
  14749. C  NO MORE RELATIONS
  14750. C
  14751.       RMSTAT = -1
  14752.       GO TO 999
  14753. C
  14754. C   VALIDATE USER
  14755. C
  14756.   200 CONTINUE
  14757.       IF(EQ(NAME,K8RDT)) GO TO 100
  14758.       IF(EQ(NAME,K8RRC)) GO TO 100
  14759.       IF(EQ(USERID,OWNER)) GO TO 300
  14760.       IF(EQ(RPW,NONE)) GO TO 300
  14761.       IF(EQ(RPW,USERID)) GO TO 300
  14762.       IF(EQ(MPW,USERID)) GO TO 300
  14763.       GO TO 100
  14764. C
  14765. C  TRANSFER THE RELATION DATA TO THE PROPER ARGUMENTS
  14766. C
  14767.   300 CONTINUE
  14768.       RNAME = NAME
  14769.       LRPW =.TRUE.
  14770.       IF(EQ(RPW,NONE)) LRPW= .FALSE.
  14771.       LMPW = .TRUE.
  14772.       IF(EQ(MPW,NONE)) LMPW = .FALSE.
  14773.       LASTMD = RDATE
  14774.       NUMATT = NATT
  14775.       NUMTUP = NTUPLE
  14776.   999 RETURN
  14777.       END
  14778.       SUBROUTINE RMGTSO(MAT,INDEX,IFLAG,LENGTH,INDPTR)
  14779.         Include TEXT.BLK
  14780. C
  14781. C  PURPOSE:  READ IN TUPLES FROM THE SORTED DATA FILE
  14782. C
  14783. C  PARAMETERS:
  14784. C            MAT-----ARRAY TO HOLD ONE TUPLE (IF IFLAG = 1)
  14785. C                    POINTER TO TUPLE IN BUFFER (IF IFLAG = 0)
  14786. C           INDEX---PAGE BUFFER TO USE
  14787. C            IFLAG---0 IF THE TUPLE IS RETURNED IN MAT
  14788. C                    1 IF THE BUFFER POINTER IS RETURNED IN MAT
  14789. C                   -1 OPEN THE SORT FILE AND INITIALIZE
  14790. C            LENGTH--LENGTH OF TUPLE IN WORDS
  14791. C            INDPTR--MULTIPLE RMHUNT INDEX - USED TO ASSIGN FILES
  14792. C
  14793.         Include SRTCOM.BLK
  14794.         Include WHCOM.BLK
  14795.         Include RIMCOM.BLK
  14796.         Include BUFFER.BLK
  14797.         Include F2COM.BLK
  14798.         Include MISC.BLK
  14799. C
  14800.       DIMENSION MAT(1)
  14801.       INFIL = 20 + INDPTR
  14802. C
  14803. C  IF IFLAG IS NOT -1 SKIP THE SORT FILE/BUFFER INITIALIZATION
  14804. C
  14805.       IF(IFLAG.NE.-1) GO TO 500
  14806. C
  14807. C  FIRST CALL -----
  14808. C
  14809. C  REWIND THE SORT FILE NEEDED
  14810. C
  14811.       REWIND INFIL
  14812. C
  14813. C  ESTABLISH THE BUFFER POINTER
  14814. C
  14815. C  SEE IF THE CURRENT BLOCK NEEDS WRITING
  14816. C
  14817.       IF(INDEX.GT.3) GO TO 200
  14818.       IF(MODFLG(INDEX).EQ.0) GO TO 100
  14819. C
  14820. C  WRITE OUT THE CURRENT BLOCK
  14821. C
  14822.       KQ1 = BLKLOC(INDEX)
  14823.       CALL RIOOUT(FILE2,CURBLK(INDEX),BUFFER(KQ1),LENBF2,IOS)
  14824.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  14825.   100 MODFLG(INDEX) = 0
  14826.       CURBLK(INDEX) = 0
  14827. C
  14828. C  ESTABLISH THE NEW BUFFER BLOCK
  14829. C
  14830.   200 CONTINUE
  14831.       CALL BLKCHG(INDEX,MAXCOL,1)
  14832. C
  14833. C  SET THE TUPLES READ COUNTED TO 0
  14834. C
  14835.       NREAD = 0
  14836. C
  14837. C  ALL INITIALIZATION COMPLETE -- RETURN
  14838. C
  14839.       RETURN
  14840. C
  14841. C  READ IN A TUPLE FROM THE SORT FILE
  14842. C
  14843.   500 CONTINUE
  14844.       CALL BLKCHG(INDEX,MAXCOL,1)
  14845.       KQ1 = BLKLOC(INDEX) - 1
  14846.       NREAD = NREAD + 1
  14847.       IF(NREAD.GT.LIMTU) GO TO 900
  14848.       IF(NREAD.GT.NSORT) GO TO 900
  14849.       IF(FIXLT) GO TO 600
  14850. C
  14851. C  VARIABLE LENGTH TUPLES
  14852. C
  14853.       READ(INFIL) LENGTH,(BUFFER(KQ1+K),K=1,LENGTH)
  14854.       GO TO 700
  14855. C
  14856. C  FIXED LENGTH TUPLES
  14857. C
  14858.   600 CONTINUE
  14859.       READ(INFIL) (BUFFER(KQ1+K),K=1,LENGTH)
  14860. C
  14861. C  TUPLE READ - SET MAT AND RMSTAT
  14862. C
  14863.   700 CONTINUE
  14864.       RMSTAT = 0
  14865.       MAT(1) = KQ1 + 1
  14866.       IF(IFLAG.NE.0) GO TO 999
  14867. C
  14868. C  LOAD TUPLE INTO MAT
  14869. C
  14870.       DO 800 K=1,LENGTH
  14871.       MAT(K) = BUFFER(KQ1+K)
  14872.   800 CONTINUE
  14873.       GO TO 999
  14874. C
  14875. C  ALL DONE - SET RMSTAT AND CLOSE THE FILE
  14876. C
  14877.   900 CONTINUE
  14878.       RMSTAT = -1
  14879.       CALL BLKCLR(INDEX)
  14880.       CLOSE(UNIT=INFIL,STATUS='DELETE')
  14881. C
  14882.   999 CONTINUE
  14883.       RETURN
  14884.       END
  14885.       SUBROUTINE RMHELP
  14886.         Include TEXT.BLK
  14887. C
  14888. C     THIS ROUTINE PROCESSES THE RIM HELP
  14889. C     COMMAND.  THE HELP DATA BASE HAS 3 ATTRIBUTES -
  14890. C     KEY3    - A 3 CHARACTER FIELD FOR FINDING THE LAST COMMAND
  14891. C               DOES NOT ALLOW DISCRIMINATION BETWEEN DIFFERENT
  14892. C               RENAMES OR DELETES
  14893. C     VERBAGE - A VARIABLE TEXT FIELD WITH A LINE OF STUFF. A ONE
  14894. C               CHARACTER FIELD IS A FLAG FOR END OF PAGE.
  14895. C     COMMAND - A 20 CHARACTER FIELD WITH THE FULL COMMAND NAME.
  14896. C
  14897. C     THE CURRENT DATA BASE FILE IS CLOSED AND THE HELP FILES OPENED.
  14898. C     THE CURRENT COMMAND IS LOCATED IN THE DATA BASE UNLESS
  14899. C     SOMETHING ELSE IS REQUESTED.  AFTER PROCESSING HELP COMMANDS,
  14900. C     THE HELP DATA BASE IS CLOSED AND THE USERS DATA BASE IS REOPENED.
  14901. C
  14902.         Include RMATTS.BLK
  14903.         Include RMKEYW.BLK
  14904.         Include CONST4.BLK
  14905.         Include FILES.BLK
  14906.         Include FLAGS.BLK
  14907.         Include RIMCOM.BLK
  14908.         Include TUPLER.BLK
  14909.         Include BUFFER.BLK
  14910.         Include WHCOM.BLK
  14911.         Include MISC.BLK
  14912.         Include TUPLEA.BLK
  14913.         Include SELCOM.BLK
  14914.         Include RIMPTR.BLK
  14915.         Include DCLAR4.BLK
  14916.         Include CONST8.BLK
  14917.       INTEGER SULPP,SUMCPL
  14918.       LOGICAL SPCENT,SRUCK
  14919.       LOGICAL ISAVE
  14920. C
  14921. C     SET PROMPT CHARACTER TO H FOR HELPPPPPPPP
  14922. C
  14923.       CALL LXSET(K4PROM,K4HP)
  14924.       STOL = TOL
  14925.       SPCENT = PCENT
  14926.       SRUCK = RUCK
  14927.       SULPP = ULPP
  14928.       SUMCPL = UMCPL
  14929. C
  14930. C     CLOSE EXISTING DATA BASE
  14931. C
  14932.       IFILE = DBNAME
  14933.       ISAVE = DFLAG
  14934.       CALL RMOPEN(K8HDB)
  14935. C
  14936. C     SET UP PRELIMINARY WHERE CLAUSE
  14937. C
  14938.       NBOO = 1
  14939.       BOO(1) = K4AND
  14940.       KOMTYP(1) = 2
  14941.       KOMPOS(1) = 1
  14942.       KOMLEN(1) = 1
  14943.       KOMPOT(1) = 1
  14944.       LIMTU = ALL9S
  14945.       MAXTU = ALL9S
  14946.       KSTRT = 0
  14947.       NS = 0
  14948.       ITEMS = LXITEM(IDUM)
  14949.       IP = 2
  14950.       IF(ITEMS.GT.1) GO TO 1100
  14951. C
  14952. C     USE LAST COMMAND VIA KEY3 ATTRIBUTE
  14953. C
  14954.       CALL HTOI(3,1,KATTL(1))
  14955.       CALL HTOI(3,1,WHRLEN(1))
  14956.       WHRVAL(1) = LSTCMD
  14957.       KATTP(1) = 1
  14958.       KATTY(1) = KZTEXT
  14959.       I = LOCREL(KWHELP)
  14960.       IF(I.NE.0) GO TO 8000
  14961.       I = LOCATT(BLANK,NAME)
  14962.       IF(I.NE.0) GO TO 8000
  14963.       CALL ATTGET(ISTAT)
  14964.       KSTRT = ATTKEY
  14965.       IF(KSTRT.NE.0) NS = 2
  14966. C
  14967. C     GO PRINT VERBAGE
  14968. C
  14969.       GO TO 2000
  14970.  1000 CONTINUE
  14971.       IP = 1
  14972. C
  14973. C     GET NEXT INPUT
  14974. C
  14975.       WRITE (NOUT,1005)
  14976.  1005 FORMAT(32H ENTER END TO END HELP OR A RIM ,
  14977.      X       19HKEYWORD TO CONTINUE )
  14978.       CALL LXLREC(IDUM,0,IDUM)
  14979.       ITEMS = LXITEM(IDUM)
  14980.       IF(ITEMS.GT.1) GO TO 1100
  14981.       IF(LXID(1).EQ.K4EOF) GO TO 9000
  14982.       IF(LXID(1).NE.KZTEXT) GO TO 8100
  14983.       IF(LXWREC(1,1).EQ.K4END) GO TO 9000
  14984.  1100 CONTINUE
  14985. C
  14986. C     SET UP WHERE CLAUSE FOR USER ENTERD COMMAND
  14987. C
  14988.       I = LOCREL(KWHELP)
  14989.       IF(I.NE.0) GO TO 8000
  14990.       I = LOCATT(K8COMM,NAME)
  14991.       IF(I.NE.0) GO TO 8000
  14992.       CALL ATTGET(ISTAT)
  14993.       KATTP(1) = ATTCOL
  14994.       KATTL(1) = ATTLEN
  14995.       KATTY(1) = ATTYPE
  14996.       KSTRT = ATTKEY
  14997.       IF(KSTRT.NE.0) NS = 2
  14998.       IF(LXID(IP).NE.KZTEXT) GO TO 8100
  14999.       NC = LXLENC(IP)
  15000.       CALL FILCH(WHRVAL,1,20,BLANK)
  15001.       CALL LXSREC(IP,1,NC,WHRVAL,1)
  15002.       IP = IP + 1
  15003.       IF(IP.GT.ITEMS) GO TO 1150
  15004. C
  15005. C     GET ANOTHER ITEM
  15006. C
  15007.       MC = LXLENC(IP)
  15008.       IF(LXID(IP).NE.KZTEXT) GO TO 8100
  15009.       CALL LXSREC(IP,1,MC,WHRVAL,NC+2)
  15010.  1150 CONTINUE
  15011.       WHRLEN(1) = ATTLEN
  15012.  2000 CONTINUE
  15013. C
  15014. C     LOOP THRU RECORDS AND DISPLAY
  15015. C
  15016.       CALL RMLOOK(ITUP,1,1,LENGTH)
  15017.       IF(RMSTAT.EQ.0) GO TO 2100
  15018.       WRITE (NOUT,2050)
  15019.  2050 FORMAT(42H UNABLE TO FIND HELP FOR REQUESTED COMMAND )
  15020.       GO TO 1000
  15021.  2100 CONTINUE
  15022.       ITEXT = ITUP + BUFFER(ITUP+1)
  15023.       NC = BUFFER(ITEXT)
  15024.       NW = BUFFER(ITEXT-1)
  15025.       IF(NC.NE.1) WRITE(NOUT,2150)(BUFFER(ITEXT+I),I=1,NW)
  15026.  2150 FORMAT(20A4)
  15027.       IF(NC.NE.1) GO TO 2300
  15028. C
  15029. C     PAGE BREAK
  15030. C
  15031.       WRITE (NOUT,2250)
  15032.  2250 FORMAT(28H MORE TEXT FOLLOWS - ENTER * ,
  15033.      X       28H TO CONTINUE OR QUIT TO STOP )
  15034.       CALL LXLREC(IDUM,0,IDUM)
  15035.       IF(LXID(1).EQ.K4EOF) GO TO 2300
  15036.       IF(LXWREC(1,1).EQ.K4QUIT) GO TO 1000
  15037.  2300 CONTINUE
  15038.       CALL RMLOOK(ITUP,1,1,LENGTH)
  15039.       IF(RMSTAT.EQ.0) GO TO 2100
  15040.       GO TO 1000
  15041.  8000 CONTINUE
  15042. C
  15043. C     HELP NOT AVAILABLE
  15044. C
  15045.       WRITE (NOUT,8005)
  15046.  8005 FORMAT(32H HELP IS NOT CURRENTLY AVAILABLE )
  15047.       GO TO 9000
  15048.  8100 CONTINUE
  15049. C
  15050. C     NON TEXT INPUT
  15051. C
  15052.       WRITE (NOUT,8105)
  15053.  8105 FORMAT(28H HELP REQUIRES TEXT COMMANDS )
  15054.       GO TO 1000
  15055.  9000 CONTINUE
  15056. C
  15057. C     TRY TO REVERT TO ENTRY CONDITIONS
  15058. C
  15059.       CALL RMCLOS
  15060.       IF(ISAVE) CALL RMOPEN(IFILE)
  15061.       CALL LXSET(K4PRES,IDUM)
  15062.       TOL = STOL
  15063.       PCENT = SPCENT
  15064.       RUCK = SRUCK
  15065.       SULPP = ULPP
  15066.       SUMCPL = UMCPL
  15067.       WRITE (NOUT,9005)
  15068.  9005 FORMAT(20H ENTER NEXT COMMAND )
  15069.       RETURN
  15070.       END
  15071.       SUBROUTINE RMLATT(RNAME)
  15072.         Include TEXT.BLK
  15073. C
  15074. C  PURPOSE: THIS ROUTINE SETS THE POINTERS TO THE FIRST ATTRIBUTE
  15075. C           OF RELATION RNAME
  15076. C           (FORTRAN INTERFACE COVER ROUTINE FOR LOCATT)
  15077. C
  15078. C  PARAMETERS: RNAME--RELATION NAME
  15079. C
  15080.         Include RIMPTR.BLK
  15081.         Include RIMCOM.BLK
  15082.         Include FLAGS.BLK
  15083.         Include TUPLER.BLK
  15084.         Include MISC.BLK
  15085.       INTEGER STATUS
  15086.       LOGICAL EQ
  15087.         Include DCLAR1.BLK
  15088. C
  15089.       RMSTAT = 0
  15090.       INDCUR = NULL
  15091. C
  15092. C         MAKE SURE DB IS DEFINED
  15093. C
  15094.       IF(DFLAG) GOTO 10
  15095.       RMSTAT = 16
  15096.       GOTO 999
  15097. C
  15098.    10 CONTINUE
  15099.       IF(RNAME.EQ.NAME) GO TO 200
  15100.       I = LOCREL(RNAME)
  15101.       IF(I.EQ.0) GO TO 100
  15102.       RMSTAT = 20
  15103.       GO TO 999
  15104. C
  15105. C  GET THE RELATION PASSWORDS
  15106. C
  15107.   100 CONTINUE
  15108.       CALL RELGET(STATUS)
  15109.       IF(STATUS.NE.0) GO TO 999
  15110. C
  15111. C   CHECK PERMISSION
  15112. C
  15113.       IF(EQ(USERID,OWNER)) GO TO 200
  15114.       IF(EQ(RPW,NONE)) GO TO 200
  15115.       IF(EQ(RPW,USERID)) GO TO 200
  15116.       IF(EQ(MPW,USERID)) GO TO 200
  15117.       RMSTAT = 90
  15118.       GO TO 999
  15119.   200 CONTINUE
  15120.       J = LOCATT(BLANK,RNAME)
  15121.   999 RETURN
  15122.       END
  15123.       SUBROUTINE RMLOAD(INDPTR,TUPLE)
  15124.         Include TEXT.BLK
  15125. C
  15126. C  THIS ROUTINE LOADS DATA FROM TUPLE INTO THE CURRENT RELATION.
  15127. C
  15128. C  PARAMETERS:
  15129. C         INDPTR--INDEX TO SAVE BLOCK (RANGE OF 0 TO 9)
  15130. C         TUPLE---USER ARRAY WITH REPLACEMENT TUPLE
  15131.         Include RIMCOM.BLK
  15132.         Include VARDAT.BLK
  15133.         Include KEYDAT.BLK
  15134.         Include MISC.BLK
  15135.         Include FLAGS.BLK
  15136.         Include RULCOM.BLK
  15137.         Include RIMPTR.BLK
  15138.         Include WHCOM.BLK
  15139.         Include CONST4.BLK
  15140.         Include RMATTS.BLK
  15141.         Include TUPLER.BLK
  15142.         Include TUPLEA.BLK
  15143.         Include START.BLK
  15144.       INTEGER COLUMN
  15145. C
  15146.       INTEGER TUPLE(1)
  15147.       RMSTAT = 0
  15148. C         MAKE SURE DB IS DEFINED
  15149. C
  15150.       IF(DFLAG) GOTO 10
  15151.       RMSTAT = 16
  15152.       GOTO 9999
  15153. C
  15154.    10 CONTINUE
  15155. C
  15156. C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
  15157. C
  15158.       CALL RMDBLK(DBNAME)
  15159.       IF(RMSTAT.NE.0) GO TO 9999
  15160. C
  15161. C  RESTORE THE BLOCKS AS NEEDED.
  15162. C
  15163.       CALL RMRES(INDPTR)
  15164.       IF(RMSTAT.NE.0) GO TO 9999
  15165. C
  15166. C  SET THE INDEX POINTER
  15167. C
  15168.       INDEX = INDPTR
  15169.       IF(INDEX.EQ.0) INDEX = 1
  15170.       IF(INDEX.GT.3) INDEX = 3
  15171. C
  15172. C  CHECK FOR WRITE PERMISSION ON THIS RELATION.
  15173. C
  15174.       I = LOCPRM(NAME,2)
  15175.       IF(RMSTAT.NE.0) GO TO 9999
  15176.       NEWL = NCOL
  15177. C
  15178. C  CONVERT THE VARIABLE ATTRIBUTE HEADERS FROM USER TO INTERNAL
  15179. C
  15180.       IF(NUMVAR.EQ.0) GOTO 360
  15181.       CALL RMVARC(1,TUPLE)
  15182.       IF(RMSTAT.NE.0) GO TO 9999
  15183. C
  15184. C  FIND OUT HOW LONG THE NEW TUPLE IS.
  15185. C
  15186.   200 CONTINUE
  15187.       I = LOCATT(BLANK,NAME)
  15188.       NEWL = 0
  15189.   320 CONTINUE
  15190.       CALL ATTGET(ISTAT)
  15191.       IF(ISTAT.NE.0) GO TO 360
  15192.       NWORDS = ATTWDS
  15193.       IF(ATTWDS.NE.0) GO TO 340
  15194. C
  15195. C  VARIABLE LENGTH ATTRIBUTE.
  15196. C
  15197.       COLUMN = TUPLE(ATTCOL)
  15198.       IF((COLUMN.LE.1).OR.(COLUMN.GT.MAXCOL)) GO TO 800
  15199.       NWORDS = TUPLE(COLUMN) + 3
  15200.       IF(NWORDS.LE.3) GO TO 800
  15201.   340 CONTINUE
  15202.       NEWL = NEWL + NWORDS
  15203.       GO TO 320
  15204.   360 CONTINUE
  15205.       IF(NEWL.GT.MAXCOL) GO TO 800
  15206. C
  15207. C  SEE IF ANY APPLICABLE RULES ARE MET.
  15208. C
  15209.       IF(.NOT.RUCK) GO TO 440
  15210.       IF(.NOT.RULES) GO TO 440
  15211. C
  15212. C  SAVE THE CURRENT POSITION DATA
  15213. C
  15214.       CALL RMSAV(INDCUR)
  15215. C
  15216. C  LOAD THE RULE WHERE CLAUSE
  15217. C
  15218.       NBOO = 1
  15219.       BOO(1) = K4AND
  15220.       KATTP(1) = 1
  15221.       KATTL(1) = 1
  15222.       KATTY(1) = KZINT
  15223.       KOMTYP(1) = 2
  15224.       KOMPOS(1) = 1
  15225.       KOMLEN(1) = 1
  15226.       KOMPOT(1) = 1
  15227.       KSTRT = 0
  15228.       MAXTU = ALL9S
  15229.       LIMTU = ALL9S
  15230.       WHRVAL(1) = 0
  15231.       WHRLEN(1) = 1
  15232.       CALL CHKTUP(TUPLE,ISTAT)
  15233.       RMSTAT = 0
  15234.       IF(ISTAT.GT.0) RMSTAT = 200 + ISTAT
  15235.       IF(ISTAT.LT.0) RMSTAT = 112
  15236. C
  15237. C  RESTORE THE CURRENT POSITION DATA
  15238. C
  15239.       INDCUR = 0
  15240.       CALL RMRES(INDPTR)
  15241.       IF(RMSTAT.EQ.0) GO TO 440
  15242.       GO TO 9999
  15243. C
  15244. C  ADD THE NEW TUPLE.
  15245. C
  15246.   440 CONTINUE
  15247.       CALL ADDDAT(INDEX,REND,TUPLE,NEWL)
  15248.       IF(RSTART.EQ.0) RSTART = REND
  15249.       RDATE = DBDATE
  15250.       NTUPLE = NTUPLE + 1
  15251.       CALL RELPUT
  15252.       IF(NUMKEY.EQ.0) GO TO 9999
  15253. C
  15254. C  FIX UP THE KEYS FOR THE ADDED TUPLE.
  15255. C
  15256.       I = 0
  15257.       IF(NUMKEY.LE.5) GO TO 460
  15258.       I = LOCATT(BLANK,NAME)
  15259.   460 CONTINUE
  15260.       IF(NUMKEY.GT.5) GO TO 465
  15261.       I  = I + 1
  15262.       IF(I.GT.NUMKEY) GO TO 9999
  15263.       START = KEYDAT(1,I)
  15264.       KSTART = KEYDAT(1,I)
  15265.       COLUMN = KEYDAT(2,I)
  15266.       ATTWDS = KEYDAT(3,I)
  15267.       ATTYPE = KEYDAT(4,I)
  15268.       GO TO 470
  15269.   465 CONTINUE
  15270.       CALL ATTGET(ISTAT)
  15271.       IF(ISTAT.NE.0) GO TO 9999
  15272.       IF(ATTKEY.EQ.0) GO TO 460
  15273.       START = ATTKEY
  15274.       KSTART = ATTKEY
  15275.       COLUMN = ATTCOL
  15276.   470 CONTINUE
  15277.       IF(ATTWDS.NE.0) GO TO 480
  15278.       COLUMN = TUPLE(COLUMN) + 2
  15279.   480 CONTINUE
  15280.       IF(TUPLE(COLUMN).EQ.NULL) GO TO 460
  15281.       CALL BTADD(TUPLE(COLUMN),REND,ATTYPE)
  15282.       IF(START.EQ.KSTART) GO TO 460
  15283.       IF(NUMKEY.LE.5) GO TO 490
  15284.       ATTKEY = START
  15285.       CALL ATTPUT(ISTAT)
  15286.       GO TO 460
  15287.   490 CONTINUE
  15288.       ISTAT = LOCATT(KEYDAT(5,I),NAME)
  15289.       CALL ATTGET(ISTAT)
  15290.       ATTKEY = START
  15291.       CALL ATTPUT(ISTAT)
  15292.       KEYDAT(1,I) = START
  15293.       GO TO 460
  15294. C
  15295. C  NEW TUPLE HAS VARIABLE LENGTH POINTERS WHICH ARE WIERD.
  15296. C
  15297.   800 CONTINUE
  15298.       RMSTAT = 100
  15299.  9999 CONTINUE
  15300.       RETURN
  15301.       END
  15302.       SUBROUTINE RMLOOK(MAT,INDEX,IFLAG,LENGTH)
  15303.         Include TEXT.BLK
  15304. C
  15305. C   LOCATE NEXT DESIRED TUPLE
  15306. C
  15307. C  PARAMETERS:
  15308. C         MAT-----ARRAY TO HOLD ONE TUPLE
  15309. C                 IF(IFLAG.NE.0) MAT IS POINTER TO TUPLE
  15310. C                 IN INPUT BUFFER.
  15311. C         INDEX---PAGE BUFFER TO USE
  15312. C         IFLAG---0 IFF TUPLE IS RETURNED
  15313. C                 ELSE POINTER TO TUPLE IS RETURNED IN MAT
  15314. C         LENGTH--LENGTH OF TUPLE IN WORDS
  15315.         Include RMATTS.BLK
  15316.         Include CONST4.BLK
  15317.         Include MISC.BLK
  15318.         Include RIMCOM.BLK
  15319.         Include RIMPTR.BLK
  15320.         Include WHCOM.BLK
  15321.         Include START.BLK
  15322.         Include BUFFER.BLK
  15323.         Include FLAGS.BLK
  15324. C
  15325.       DIMENSION MAT(1)
  15326.       LOGICAL QUAL,OK,BTEST
  15327.       LOGICAL EQTEST
  15328. C
  15329. C  SCAN MAT.
  15330. C
  15331.       RMSTAT = 0
  15332.     1 CONTINUE
  15333. C
  15334. C  SEE IF WE ARE USING A KEY VALUE.
  15335. C
  15336.       IF(NS.EQ.0) GO TO 30
  15337.       IF(NS.EQ.3) GO TO 10
  15338. C
  15339. C  FIRST TIME THROUGH. USE BTLOOK TO FIND THE TUPLES.
  15340. C
  15341.       START = KSTRT
  15342.       NBOOX = IABS(NBOO)
  15343.       NUMP = KOMPOS(NBOOX)
  15344.       IF(KATTY(NBOOX).EQ.KZINT ) CALL BTLKI(WHRVAL(NUMP),NID,MID)
  15345.       IF(KATTY(NBOOX).EQ.KZREAL) CALL BTLKR(WHRVAL(NUMP),NID,MID)
  15346.       IF(KATTY(NBOOX).EQ.KZDOUB) CALL BTLKR(WHRVAL(NUMP),NID,MID)
  15347.       IF(KATTY(NBOOX).EQ.KZTEXT) CALL BTLKT(WHRVAL(NUMP),NID,MID)
  15348.       NS = 3
  15349.       IF(NID.NE.0) GO TO 20
  15350.    10 CONTINUE
  15351.       IF(MID.EQ.0) GO TO 1300
  15352.       CALL MOTSCN(MID,NID)
  15353.       IF(NID.NE.0) GO TO 20
  15354.       GO TO 10
  15355.    20 CONTINUE
  15356.       CID = NID
  15357.       CALL GETDAT(INDEX,NID,ITUP,LENGTH)
  15358.       GO TO 40
  15359.    30 CONTINUE
  15360.       IF(NID.EQ.0) GO TO 1300
  15361.       CALL ITOH(N1,N2,NID)
  15362.       IF(N2.EQ.0) GO TO 1300
  15363.       CID = NID
  15364.       CALL GETDAT(INDEX,NID,ITUP,LENGTH)
  15365.       IF(NID.LT.0) GO TO 1300
  15366. C
  15367. C  SCAN THROUGH EACH BOOLEAN CONDITION OF THE WHERE CLAUSE.
  15368. C
  15369.    40 CONTINUE
  15370.       IVAL = IVAL + 1
  15371.       IF(NBOO.LE.0) GO TO 1200
  15372.       IF(IVAL.GT.MAXTU) GO TO 1300
  15373.       QUAL = .TRUE.
  15374.       DO 1000 J=1,NBOO
  15375.       ITYPE = KATTY(J)
  15376.       IF(ITYPE.EQ.0)ITYPE = KZINT
  15377.       OK = .FALSE.
  15378.       CALL ITOH(NR,LEN,KATTL(J))
  15379.       NUM = KOMLEN(J)
  15380.       NK = KOMTYP(J)
  15381.       NUMP = KOMPOS(J)
  15382.       IP = ITUP + KATTP(J) - 1
  15383.       IF(KATTP(J).NE.0) GO TO 100
  15384. C
  15385. C  TUPLE NUMBERS
  15386. C
  15387.       OK = .TRUE.
  15388.       IF(NK.EQ.2) OK = .FALSE.
  15389.       DO 80 JJ=1,NUM
  15390.       BTEST = .FALSE.
  15391.       CALL KOMPXX(IVAL,WHRVAL(JJ+NUMP-1),1,NK,BTEST,ITYPE)
  15392.       IF(NK.EQ.2) OK = OK .OR. BTEST
  15393.       IF(NK.NE.2) OK = OK .AND. BTEST
  15394.    80 CONTINUE
  15395.       GO TO 900
  15396.   100 CONTINUE
  15397.       IF(NK.LT.10) GO TO 300
  15398. C
  15399. C  ATTRIBUTE - ATTRIBUTE COMPARISON
  15400. C
  15401.       KP = ITUP + NUMP - 1
  15402. C
  15403. C  DUMMY TOLERANCE FOR ATTRIBUTE TO ATTRIBUTE
  15404. C
  15405.       IF(LEN.NE.0) GO TO 120
  15406. C
  15407. C     SET POINTER FOR VARIABLE ATTRIBUTES
  15408. C
  15409.       IP = BUFFER(IP) + ITUP - 1
  15410.       KP = BUFFER(KP) + ITUP - 1
  15411.       IF(NK.EQ.13) OK = .TRUE.
  15412.       LEN = BUFFER(IP)
  15413.       IF(BUFFER(KP).NE.BUFFER(IP)) GO TO 900
  15414.       IF(BUFFER(KP+1).NE.BUFFER(IP+1)) GO TO 900
  15415.       OK = .FALSE.
  15416.       IP = IP + 2
  15417.       KP = KP + 2
  15418.   120 CONTINUE
  15419.       TTOL = TOL
  15420.       TOL = 0.
  15421.       NK = NK - 10
  15422.       CALL KOMPXX(BUFFER(IP),BUFFER(KP),LEN,NK,OK,ITYPE)
  15423.       TOL = TTOL
  15424.       GO TO 900
  15425.   300 CONTINUE
  15426.       IF(LEN.NE.0) GO TO 320
  15427. C
  15428. C     SET POINTER FOR VARIABLE ATTRIBUTE
  15429. C
  15430.       IP = BUFFER(IP) + ITUP - 1
  15431.       LEN = BUFFER(IP)
  15432.       NR = BUFFER(IP+1)
  15433.       IP = IP + 2
  15434.   320 CONTINUE
  15435. C
  15436. C     REGULAR ATTRIBUTE
  15437. C
  15438.       NPOS = KOMPOS(J)
  15439.       NPOT = KOMPOT(J)
  15440.       OK = .TRUE.
  15441.       EQTEST = .FALSE.
  15442.       IF((NK.EQ.2).OR.(NK.EQ.9)) EQTEST = .TRUE.
  15443.       IF(EQTEST) OK = .FALSE.
  15444.       DO 400 JJ=1,NUM
  15445.       BTEST = .FALSE.
  15446.       CALL ITOH(NNR,NW,WHRLEN(NPOT))
  15447.       IF(NK.LE.1) GO TO 350
  15448.       IF(BUFFER(IP).EQ.NULL) GO TO 350
  15449.       IF((LEN.EQ.NW).AND.(NR.EQ.NNR)) GO TO 350
  15450. C
  15451. C     COMPARE OF DIFFERENT LENGTHS
  15452. C
  15453.       IF(NK.EQ.9) GO TO 350
  15454.       IF(NK.NE.3) GO TO 375
  15455.       OK = .TRUE.
  15456.       GO TO 900
  15457.   350 CONTINUE
  15458.       IF(NK.NE.9)CALL KOMPXX(BUFFER(IP),WHRVAL(NPOS),NW,NK,BTEST,ITYPE)
  15459.       IF(NK.NE.9) GO TO 375
  15460. C
  15461. C     CONTAINS
  15462. C
  15463.       M1 = LSTRNG(BUFFER(IP),1,NR,WHRVAL(NPOS),1,NNR)
  15464.       IF(M1.GT.0) BTEST = .TRUE.
  15465.   375 CONTINUE
  15466.       IF(EQTEST) OK = OK.OR.BTEST
  15467.       IF(.NOT.EQTEST) OK = OK.AND.BTEST
  15468.       IF(OK.AND.EQTEST) GO TO 900
  15469.       NPOS = NPOS + NW
  15470.       NPOT = NPOT + 1
  15471.   400 CONTINUE
  15472.   900 CONTINUE
  15473.       IF(BOO(J).EQ.K4AND) QUAL = QUAL .AND. OK
  15474.       IF(BOO(J).EQ.K4OR ) QUAL = QUAL .OR.  OK
  15475.  1000 CONTINUE
  15476.       IF(.NOT.QUAL) GO TO 1
  15477. C
  15478. C  FOUND IT.
  15479. C
  15480.  1200 CONTINUE
  15481.       LIMVAL = LIMVAL + 1
  15482.       IF(LIMVAL.GT.LIMTU) GO TO 1300
  15483.       MAT(1) = ITUP
  15484.       IF(IFLAG.NE.0) RETURN
  15485.       IP = ITUP
  15486.       DO 1250 I=1,LENGTH
  15487.       MAT(I) = BUFFER(IP)
  15488.       IP = IP + 1
  15489.  1250 CONTINUE
  15490.       RMSTAT = 0
  15491.       RETURN
  15492. C
  15493. C  END OF DATA.
  15494. C
  15495.  1300 CONTINUE
  15496.       NS = 0
  15497.       RMSTAT = -1
  15498.       RETURN
  15499.       END
  15500.       SUBROUTINE RMLREL
  15501.         Include TEXT.BLK
  15502. C
  15503. C  PURPOSE: THIS ROUTINE SETS THE POINTERS TO THE FIRST RELATION
  15504. C           (FORTRAN INTERFACE COVER ROUTINE FOR LOCREL)
  15505. C
  15506. C  PARAMETERS: NONE
  15507. C
  15508.         Include RIMPTR.BLK
  15509.         Include RIMCOM.BLK
  15510.         Include FLAGS.BLK
  15511.         Include MISC.BLK
  15512.         Include TUPLER.BLK
  15513.       INTEGER STATUS
  15514.       LOGICAL EQ
  15515.       RMSTAT = 0
  15516.       INDCUR = NULL
  15517. C
  15518. C         MAKE SURE DB IS DEFINED
  15519. C
  15520.       IF(DFLAG) GOTO 10
  15521.       RMSTAT = 16
  15522.       GOTO 999
  15523. C
  15524.    10 CONTINUE
  15525.       I = LOCREL(BLANK)
  15526.       NP = 0
  15527.       IF(I.EQ.0) GO TO 100
  15528.       RMSTAT = 20
  15529.       GO TO 999
  15530.   100 CONTINUE
  15531. C
  15532. C  GET THE RELATION PASSWORDS
  15533. C
  15534.       CALL RELGET(STATUS)
  15535.       IF(STATUS.NE.0) GO TO 900
  15536. C
  15537. C   VALIDATE USER
  15538. C
  15539.       IF(EQ(USERID,OWNER)) NP = 1
  15540.       IF(EQ(RPW,NONE)) NP = 1
  15541.       IF(EQ(RPW,USERID)) NP = 1
  15542.       IF(EQ(MPW,USERID)) NP = 1
  15543.       GO TO 100
  15544. C
  15545. C  CHECK FOR UNAUTHORIZED RELATION ACCESS
  15546. C
  15547.   900 CONTINUE
  15548.       IF(NP.EQ.0) RMSTAT = 90
  15549. C
  15550. C  RMLREL COMPLETE
  15551. C
  15552.   999 CONTINUE
  15553.       I = LOCREL(BLANK)
  15554.       RETURN
  15555.       END
  15556.       SUBROUTINE RMOPEN(IFILE)
  15557.         Include TEXT.BLK
  15558. C
  15559. C  PURPOSE:  OPEN A RIM DATABASE.
  15560. C
  15561. C  PARAMETERS:
  15562. C         IFILE---NAME OF THE DATABASE
  15563.         Include CONST4.BLK
  15564.         Include RIMCOM.BLK
  15565.         Include FLAGS.BLK
  15566.         Include ATTBLE.BLK
  15567.         Include MISC.BLK
  15568.         Include DCLAR4.BLK
  15569.       DATA ICALLS /0/
  15570.       IF(ICALLS.EQ.0) DFLAG = .FALSE.
  15571.       ICALLS = ICALLS + 1
  15572.       RMSTAT = 0
  15573. C
  15574. C  CLOSE ANY EXISTING DATABASES AND INITIALIZE
  15575. C
  15576.       IF(DFLAG) CALL RMCLOS
  15577.       CALL RMSTRT
  15578. C
  15579. C  SET THE NEW DATABASE NAME, DATE, AND TIME
  15580. C
  15581.       DBNAME = IFILE
  15582.       CALL RMDATE(DBDATE)
  15583.       CALL RMTIME(DBTIME)
  15584. C
  15585. C  FIND THE LAST NON-BLANK CHARACTER.
  15586. C
  15587.       DO 100 I=1,7
  15588.       CALL GETT(IFILE,I,IT)
  15589.       IF(IT.EQ.IBLANK) GO TO 200
  15590.   100 CONTINUE
  15591.       I = 7
  15592.   200 CONTINUE
  15593. C
  15594. C  FIX UP THE FILE NAMES.
  15595. C
  15596.       FILE = BLANK
  15597.       CALL STRMOV(IFILE,1,I,FILE,1)
  15598.       RIMDB1 = FILE
  15599.       CALL PUTT(RIMDB1,I,K41)
  15600.       RIMDB2 = FILE
  15601.       CALL PUTT(RIMDB2,I,K42)
  15602.       RIMDB3 = FILE
  15603.       CALL PUTT(RIMDB3,I,K43)
  15604. C
  15605. C  OPEN FILE 1.
  15606. C
  15607.       CALL F1OPN(RIMDB1)
  15608.       IF((RMSTAT.NE.0).AND.(RMSTAT.NE.15)) GO TO 999
  15609. C
  15610. C  OPEN FILE 2.
  15611. C
  15612.       CALL F2OPN(RIMDB2)
  15613.       IF((RMSTAT.NE.0).AND.(RMSTAT.NE.15)) GO TO 999
  15614. C
  15615. C  OPEN FILE 3.
  15616. C
  15617.       CALL F3OPN(RIMDB3)
  15618.       IF((RMSTAT.NE.0).AND.(RMSTAT.NE.15)) GO TO 999
  15619. C
  15620. C  IF THIS IS A NEW DATABASE WE NEED TO SET UP THE FIRST BTREE.
  15621. C
  15622.       IF(DFLAG) CALL RMDATE(DBDATE)
  15623.   999 RETURN
  15624.       END
  15625.       SUBROUTINE RMPUT(INDPTR,TUPLE)
  15626.         Include TEXT.BLK
  15627. C
  15628. C  THIS ROUTINE PUTS DATA FROM TUPLE INTO THE CURRENT ROW.
  15629. C
  15630. C  PARAMETERS:
  15631. C         INDPTR--INDEX TO SAVE BLOCK (RANGE OF 0 TO 9)
  15632. C         TUPLE---USER ARRAY WITH REPLACEMENT TUPLE
  15633.         Include KEYDAT.BLK
  15634.         Include RIMCOM.BLK
  15635.         Include VARDAT.BLK
  15636.         Include MISC.BLK
  15637.         Include FLAGS.BLK
  15638.         Include TUPLER.BLK
  15639.         Include TUPLEA.BLK
  15640.         Include RIMPTR.BLK
  15641.         Include RULCOM.BLK
  15642.         Include WHCOM.BLK
  15643.         Include CONST4.BLK
  15644.         Include RMATTS.BLK
  15645.         Include BUFFER.BLK
  15646.         Include START.BLK
  15647.       INTEGER COLUMN
  15648. C
  15649.       INTEGER TUPLE(1)
  15650.       RMSTAT = 0
  15651. C         MAKE SURE DB IS DEFINED
  15652. C
  15653.       IF(DFLAG) GOTO 10
  15654.       RMSTAT = 16
  15655.       GOTO 9999
  15656. C
  15657.    10 CONTINUE
  15658. C
  15659. C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
  15660. C
  15661.       CALL RMDBLK(DBNAME)
  15662.       IF(RMSTAT.NE.0) GO TO 9999
  15663. C
  15664. C  RESTORE THE BLOCKS AS NEEDED.
  15665. C
  15666.       CALL RMRES(INDPTR)
  15667.       IF(RMSTAT.NE.0) GO TO 9999
  15668. C
  15669. C  CHECK FOR WRITE PERMISSION ON THIS RELATION.
  15670. C
  15671.       I = LOCPRM(NAME,2)
  15672.       IF(RMSTAT.NE.0) GO TO 9999
  15673. C
  15674. C  CHECK THAT RMGET WAS CALLED
  15675. C
  15676.       IF((IVAL.GT.0).AND.(IVAL.LT.ALL9S)) GO TO 200
  15677. C
  15678. C  RMGET WAS NOT CALLED BEFORE RMPUT
  15679. C
  15680.       RMSTAT = 60
  15681.       GO TO 9999
  15682. C
  15683. C  CONVERT THE VARIABLE ATTRIBUTE HEADERS FROM USER TO INTERNAL
  15684. C
  15685.   200 CONTINUE
  15686.       IF(NUMVAR.EQ.0) GO TO 250
  15687.       CALL RMVARC(1,TUPLE)
  15688.       IF(RMSTAT.NE.0) GO TO 9999
  15689.   250 CONTINUE
  15690. C
  15691. C  CHECK FOR RULES
  15692. C
  15693.       IF(.NOT.RUCK) GO TO 290
  15694.  
  15695.       IF(.NOT.RULES) GO TO 290
  15696. C
  15697. C  SAVE THE CURRENT POSITION DATA
  15698. C
  15699.       CALL RMSAV(INDCUR)
  15700. C
  15701. C  LOAD THE RULE WHERE CLAUSE
  15702. C
  15703.       NBOO = 1
  15704.       BOO(1) = K4AND
  15705.       KATTP(1) = 1
  15706.       KATTL(1) = 1
  15707.       KATTY(1) = KZINT
  15708.       KOMTYP(1) = 2
  15709.       KOMPOS(1) = 1
  15710.       KOMLEN(1) = 1
  15711.       KOMPOT(1) = 1
  15712.       KSTRT = 0
  15713.       MAXTU = ALL9S
  15714.       LIMTU = ALL9S
  15715.       WHRVAL(1) = 0
  15716.       WHRLEN(1) = 1
  15717.       CALL CHKTUP(TUPLE,ISTAT)
  15718.       RMSTAT = 0
  15719.       IF(ISTAT.GT.0) RMSTAT = 200 + ISTAT
  15720.       IF(ISTAT.LT.0) RMSTAT = 112
  15721. C
  15722. C  RESTORE THE CURRENT POSITION DATA
  15723. C
  15724.       INDCUR = 0
  15725.       CALL RMRES(INDPTR)
  15726.       IF(RMSTAT.EQ.0) GO TO 290
  15727.       GO TO 9999
  15728. C
  15729. C  RETRIEVE THE CURRENT ROW IN A SCRATCH TUPLE.
  15730. C
  15731.   290 CONTINUE
  15732.       CALL BLKCHG(11,MAXCOL,1)
  15733.       KQ1 = BLKLOC(11)
  15734.       NID = CID
  15735.       INDEX = INDPTR
  15736.       IF(INDEX.EQ.0) INDEX = 1
  15737.       IF(INDEX.GT.3) INDEX = 3
  15738.       LNBOO = NBOO
  15739.       NBOO = 0
  15740.       LNS = NS
  15741.       NS = 0
  15742.       CALL RMLOOK(BUFFER(KQ1),INDEX,0,KURLEN)
  15743.       NS = LNS
  15744.       NBOO = LNBOO
  15745.       IVAL = IVAL - 1
  15746.       IF(RMSTAT.EQ.0) GO TO 300
  15747. C
  15748. C  NO DATA AVAILABLE
  15749. C
  15750.       RMSTAT = 60
  15751.       GO TO 9999
  15752. C
  15753. C  SEE IF THE NEW TUPLE IS LONGER THAN THE OLD ONE.
  15754. C
  15755.   300 CONTINUE
  15756.       NEWL = KURLEN
  15757.       IF(NUMVAR.EQ.0) GO TO 370
  15758.       I = LOCATT(BLANK,NAME)
  15759.       NEWL = 0
  15760.   320 CONTINUE
  15761.       CALL ATTGET(ISTAT)
  15762.       IF(ISTAT.NE.0) GO TO 360
  15763.       NWORDS = ATTWDS
  15764.       IF(ATTWDS.NE.0) GO TO 340
  15765. C
  15766. C  VARIABLE LENGTH ATTRIBUTE.
  15767. C
  15768.       COLUMN = TUPLE(ATTCOL)
  15769.       IF((COLUMN.LE.1).OR.(COLUMN.GT.MAXCOL)) GO TO 800
  15770.       NWORDS = TUPLE(COLUMN) + 3
  15771.       IF(NWORDS.LT.3) GO TO 800
  15772.   340 CONTINUE
  15773.       NEWL = NEWL + NWORDS
  15774.       GO TO 320
  15775.   360 CONTINUE
  15776.       IF(NEWL.GT.MAXCOL) GO TO 800
  15777.   370 CONTINUE
  15778.       IF(NEWL.LE.KURLEN) GO TO 500
  15779. C
  15780. C  NEW TUPLE IS LONGER THAN THE OLD ONE.
  15781. C  OLD TUPLE MUST BE DELETED AND THE CHANGED ONE ADDED.
  15782. C
  15783.       CALL DELDAT(INDEX,CID)
  15784. C
  15785. C  CHANGE THE POINTERS FOR ANY KEY ELEMENTS.
  15786. C
  15787.       IF(NUMKEY.EQ.0) GO TO 440
  15788.       I = 0
  15789.       IF(NUMKEY.LE.5) GO TO 380
  15790.       I = LOCATT(BLANK,NAME)
  15791.   380 CONTINUE
  15792.       IF(NUMKEY.GT.5) GO TO 390
  15793.       I = I + 1
  15794.       IF(I.GT.NUMKEY) GO TO 440
  15795.       START = KEYDAT(1,I)
  15796.       COLUMN = KEYDAT(2,I)
  15797.       ATTWDS = KEYDAT(3,I)
  15798.       ATTYPE = KEYDAT(4,I)
  15799.       GO TO 395
  15800.   390 CONTINUE
  15801.       CALL ATTGET(ISTAT)
  15802.       IF(ISTAT.NE.0) GO TO 440
  15803.       IF(ATTKEY.EQ.0) GO TO 380
  15804.       START = ATTKEY
  15805.       COLUMN = ATTCOL
  15806.   395 CONTINUE
  15807.       IF(ATTWDS.NE.0) GO TO 400
  15808.       COLUMN = BUFFER(KQ1+COLUMN-1) + 2
  15809.   400 CONTINUE
  15810.       IF(BUFFER(KQ1+COLUMN-1).EQ.NULL) GO TO 380
  15811.       CALL BTREP(BUFFER(KQ1+COLUMN-1),0,CID,ATTYPE)
  15812.       GO TO 380
  15813. C
  15814. C  ADD THE NEW TUPLE.
  15815. C
  15816.   440 CONTINUE
  15817.       IF(CID.EQ.RSTART) RSTART = NID
  15818.       CALL ADDDAT(INDEX,REND,TUPLE,NEWL)
  15819.       RDATE = DBDATE
  15820.       CALL RELPUT
  15821. C
  15822. C  FIX UP THE KEYS FOR THE ADDED TUPLE.
  15823. C
  15824.       IF(NUMKEY.EQ.0) GO TO 9999
  15825.       I = 0
  15826.       IF(NUMKEY.LE.5) GO TO 460
  15827.       I = LOCATT(BLANK,NAME)
  15828.   460 CONTINUE
  15829.       IF(NUMKEY.GT.5) GO TO 470
  15830.       I = I + 1
  15831.       IF(I.GT.NUMKEY) GO TO 9999
  15832.       START = KEYDAT(1,I)
  15833.       COLUMN = KEYDAT(2,I)
  15834.       ATTWDS = KEYDAT(3,I)
  15835.       ATTYPE = KEYDAT(4,I)
  15836.       GO TO 475
  15837.   470 CONTINUE
  15838.       CALL ATTGET(ISTAT)
  15839.       IF(ISTAT.NE.0) GO TO 9999
  15840.       IF(ATTKEY.EQ.0) GO TO 460
  15841.       START = ATTKEY
  15842.       KSTART = ATTKEY
  15843.       COLUMN = ATTCOL
  15844.   475 CONTINUE
  15845.       IF(ATTWDS.NE.0) GO TO 480
  15846.       COLUMN = TUPLE(COLUMN) + 2
  15847.   480 CONTINUE
  15848.       IF(TUPLE(COLUMN).EQ.NULL) GO TO 460
  15849.       CALL BTADD(TUPLE(COLUMN),REND,ATTYPE)
  15850.       IF(START.EQ.KSTART) GO TO 460
  15851.       IF(NUMKEY.LE.5) GO TO 490
  15852.       ATTKEY = START
  15853.       CALL ATTPUT(ISTAT)
  15854.       GO TO 460
  15855.   490 CONTINUE
  15856.       ISTAT = LOCATT(KEYDAT(5,I),NAME)
  15857.       CALL ATTGET(ISTAT)
  15858.       ATTKEY = START
  15859.       CALL ATTPUT(ISTAT)
  15860.       GO TO 460
  15861. C
  15862. C  NEW TUPLE WILL FIT IN PLACE.
  15863. C
  15864.   500 CONTINUE
  15865.       CALL PUTDAT(INDEX,CID,TUPLE,NEWL)
  15866.       RDATE = DBDATE
  15867.       CALL RELPUT
  15868. C
  15869. C  CHANGE THE POINTERS FOR ANY KEY ATTRIBUTES.
  15870. C
  15871.       IF(NUMKEY.EQ.0) GO TO 9999
  15872.       I = 0
  15873.       IF(NUMKEY.LE.5) GO TO 520
  15874.       I = LOCATT(BLANK,NAME)
  15875.   520 CONTINUE
  15876.       IF(NUMKEY.GT.5) GO TO 530
  15877.       I = I + 1
  15878.       IF(I.GT.NUMKEY) GO TO 9999
  15879.       START = KEYDAT(1,I)
  15880.       KSTART = KEYDAT(1,I)
  15881.       IPOLD = KEYDAT(2,I)
  15882.       IPNEW = IPOLD
  15883.       ATTWDS = KEYDAT(3,I)
  15884.       ATTYPE = KEYDAT(4,I)
  15885.       GO TO 535
  15886.   530 CONTINUE
  15887.       CALL ATTGET(ISTAT)
  15888.       IF(ISTAT.NE.0) GO TO 9999
  15889.       IF(ATTKEY.EQ.0) GO TO 520
  15890.       START = ATTKEY
  15891.       KSTART = ATTKEY
  15892.       IPOLD = ATTCOL
  15893.       IPNEW = ATTCOL
  15894.   535 CONTINUE
  15895.       IF(ATTWDS.NE.0) GO TO 540
  15896. C
  15897. C  VARIABLE LENGTH ATTRIBUTE.
  15898. C
  15899.       IPOLD = BUFFER(KQ1+IPOLD-1) + 2
  15900.       IPNEW = TUPLE(IPNEW) + 2
  15901.       IF((IPNEW.LT.1).OR.(IPNEW.GT.MAXCOL)) GO TO 800
  15902.   540 CONTINUE
  15903.       IF(BUFFER(KQ1+IPOLD-1).EQ.TUPLE(IPNEW)) GO TO 520
  15904. C
  15905. C  THE VALUE CHANGED.
  15906. C
  15907.       IF(BUFFER(KQ1+IPOLD-1).NE.NULL)
  15908.      +CALL BTREP(BUFFER(KQ1+IPOLD-1),0,CID,ATTYPE)
  15909.       IF(TUPLE(IPNEW).NE.NULL)
  15910.      +CALL BTADD(TUPLE(IPNEW),CID,ATTYPE)
  15911.       IF(START.EQ.KSTART) GO TO 520
  15912.       IF(NUMKEY.LE.5) GO TO 550
  15913.       ATTKEY = START
  15914.       CALL ATTPUT(ISTAT)
  15915.       GO TO 520
  15916.   550 CONTINUE
  15917.       ISTAT = LOCATT(KEYDAT(5,I),NAME)
  15918.       CALL ATTGET(ISTAT)
  15919.       ATTKEY = START
  15920.       CALL ATTPUT(ISTAT)
  15921.       GO TO 520
  15922. C
  15923. C  NEW TUPLE HAS VARIABLE LENGTH POINTERS WHICH ARE WIERD.
  15924. C
  15925.   800 CONTINUE
  15926.       RMSTAT = 100
  15927.  9999 CONTINUE
  15928.       RETURN
  15929.       END
  15930.       SUBROUTINE RMRES(INDPTR)
  15931.         Include TEXT.BLK
  15932. C
  15933. C  PURPOSE:   RESTORE THE INTERNAL POINTERS FOR THE NAVIGATION OF
  15934. C             MULTIPLE PROGRAM INTERFACE PATHS.
  15935. C
  15936. C  PARAMETERS:
  15937. C     INPUT:  INDPTR--INDEX TO SAVE BLOCK (RANGE OF 0 TO 9)
  15938.         Include RIMCOM.BLK
  15939.         Include VARDAT.BLK
  15940.         Include KEYDAT.BLK
  15941.         Include TUPLEA.BLK
  15942.         Include RULCOM.BLK
  15943.         Include TUPLER.BLK
  15944.         Include RIMPTR.BLK
  15945.         Include WHCOM.BLK
  15946.         Include RELTBL.BLK
  15947.         Include PTRCOM.BLK
  15948.         Include MISC.BLK
  15949.         Include SRTCOM.BLK
  15950.       LOGICAL NE
  15951.       LOGICAL EQ
  15952. C
  15953. C  SEE IF THE INDEX IS WITHIN RANGE.
  15954. C
  15955.       IF(INDCUR.EQ.NULL) GO TO 400
  15956.       IF(INDPTR.EQ.NULL) GO TO 400
  15957.       IF((INDPTR.LT.0).OR.(INDPTR.GT.9)) GO TO 500
  15958. C
  15959. C  SEE IF THE CURRENT BLOCK IS ALREADY THERE.
  15960. C
  15961.       IF(INDPTR.EQ.INDCUR) GO TO 999
  15962. C
  15963. C  SAVE THE CURRENT BLOCKS.
  15964. C
  15965.       CALL RMSAV(INDCUR)
  15966. C
  15967. C  RESTORE THE BLOCKS.
  15968. C
  15969.       DO 100 I=1,INDMAX
  15970.       IF(INDNUM(I).EQ.INDPTR) GO TO 200
  15971.   100 CONTINUE
  15972. C
  15973. C  NUMBER HAS NOT BEEN SAVED.
  15974. C
  15975.       GO TO 400
  15976.   200 CONTINUE
  15977. C
  15978. C  GET THE START OF THE POINTERS IN THE BUFFER
  15979. C
  15980.       I = INDPTR + 1
  15981.       KQ1 = SAVBLK(1,I)
  15982.       IF(KQ1.EQ.0) RETURN
  15983. C
  15984. C  MOVE THE POINTER VALUES FROM THE BUFFER TO THE COMMON BLOCKS
  15985. C
  15986. C TUPLEA
  15987.       NW = 10
  15988.       CALL BLKMOV(ATTNAM,SAVBUF(KQ1),NW)
  15989.       KQ1 = KQ1 + NW
  15990. C TUPLER
  15991.       NW = 13
  15992.       CALL BLKMOV(NAME,SAVBUF(KQ1),NW)
  15993.       KQ1 = KQ1 + NW
  15994.       IF(EQ(NAME,CNAME)) GO TO 210
  15995.       J = LOCREL(NAME)
  15996.       LRROW = LRROW + 1
  15997.   210 CONTINUE
  15998. C  RIMPTR
  15999.       CALL BLKMOV(IVAL,SAVBUF(KQ1),6)
  16000.       KQ1 = KQ1 + 6
  16001. C  VARDAT
  16002.       NUMVAR = SAVBUF(KQ1)
  16003.       NW = 1 + (NUMVAR*2)
  16004.       IF(NW.GT.11) NW = 11
  16005.       CALL BLKMOV(NUMVAR,SAVBUF(KQ1),NW)
  16006.       KQ1 = KQ1 + NW
  16007. C  KEYDAT
  16008.       NUMKEY = SAVBUF(KQ1)
  16009.       NW = 1 + (NUMKEY*6)
  16010.       IF(NW.GT.31) NW = 31
  16011.       CALL BLKMOV(NUMKEY,SAVBUF(KQ1),NW)
  16012.       KQ1 = KQ1 + NW
  16013. C  SRTCOM
  16014.       NREAD = SAVBUF(KQ1)
  16015.       NSORT = SAVBUF(KQ1+1)
  16016.       CALL BLKMOV(FIXLT,SAVBUF(KQ1+2),1)
  16017.       KQ1 = KQ1 + 3
  16018. C  RULCOM
  16019.       NW = 1
  16020.       RULCNT = SAVBUF(KQ1)
  16021.       IF(RULCNT.NE.0) NW = 18
  16022.       CALL BLKMOV(RULCNT,SAVBUF(KQ1),NW)
  16023.       KQ1 = KQ1 + NW
  16024. C  WHCOM
  16025.       NBOO = SAVBUF(KQ1)
  16026.       KSTRT = SAVBUF(KQ1+1)
  16027.       MAXTU = SAVBUF(KQ1+2)
  16028.       LIMTU = SAVBUF(KQ1+3)
  16029.       NEXPOS = SAVBUF(KQ1+4)
  16030.       NEXPOT = SAVBUF(KQ1+5)
  16031.       KQ1 = KQ1 + 6
  16032.       IF(NBOO.EQ.0) GO TO 230
  16033.       CALL BLKMOV(BOO,SAVBUF(KQ1),NBOO)
  16034.       KQ1 = KQ1 + NBOO
  16035.       CALL BLKMOV(KATTP,SAVBUF(KQ1),NBOO)
  16036.       KQ1 = KQ1 + NBOO
  16037.       CALL BLKMOV(KATTL,SAVBUF(KQ1),NBOO)
  16038.       KQ1 = KQ1 + NBOO
  16039.       CALL BLKMOV(KATTY,SAVBUF(KQ1),NBOO)
  16040.       KQ1 = KQ1 + NBOO
  16041.       CALL BLKMOV(KOMTYP,SAVBUF(KQ1),NBOO)
  16042.       KQ1 = KQ1 + NBOO
  16043.       CALL BLKMOV(KOMPOS,SAVBUF(KQ1),NBOO)
  16044.       KQ1 = KQ1 + NBOO
  16045.       CALL BLKMOV(KOMLEN,SAVBUF(KQ1),NBOO)
  16046.       KQ1 = KQ1 + NBOO
  16047.       CALL BLKMOV(KOMPOT,SAVBUF(KQ1),NBOO)
  16048.       KQ1 = KQ1 + NBOO
  16049.       CALL BLKMOV(WHRVAL,SAVBUF(KQ1),NEXPOS)
  16050.       KQ1 = KQ1 + NEXPOS
  16051.       CALL BLKMOV(WHRLEN,SAVBUF(KQ1),NEXPOT)
  16052.       KQ1 = KQ1 + NEXPOT
  16053.   230 CONTINUE
  16054.       INDCUR = INDPTR
  16055.       GO TO 999
  16056.   400 CONTINUE
  16057.       RMSTAT = 50
  16058.       GO TO 999
  16059.   500 CONTINUE
  16060.       RMSTAT = 70
  16061.   999 CONTINUE
  16062.       RETURN
  16063.       END
  16064.       SUBROUTINE RMRULE(SWITCH)
  16065.         Include TEXT.BLK
  16066. C
  16067. C  PURPOSE:   SET THE RULE CHECKING FLAG
  16068. C
  16069. C  PARAMETERS:
  16070. C         SWITCH--0 MEANS NOCHECK, NOT 0 MEANS CHECK
  16071.         Include FLAGS.BLK
  16072.       INTEGER SWITCH
  16073.       RUCK = .TRUE.
  16074.       IF(SWITCH.EQ.0) RUCK = .FALSE.
  16075.       RETURN
  16076.       END
  16077.       SUBROUTINE RMSAV(INDPTR)
  16078.         Include TEXT.BLK
  16079. C
  16080. C  PURPOSE:   SAVE THE INTERNAL POINTERS FOR THE NAVIGATION OF
  16081. C             MULTIPLE PROGRAM INTERFACE PATHS.
  16082. C
  16083. C  PARAMETERS:
  16084. C     INPUT:  INDPTR--INDEX TO SAVE BLOCK (RANGE OF 0 TO 9)
  16085.         Include CONST8.BLK
  16086.         Include MISC.BLK
  16087.         Include KEYDAT.BLK
  16088.         Include SRTCOM.BLK
  16089.         Include RULCOM.BLK
  16090.         Include RIMCOM.BLK
  16091.         Include VARDAT.BLK
  16092.         Include TUPLEA.BLK
  16093.         Include TUPLER.BLK
  16094.         Include RIMPTR.BLK
  16095.         Include WHCOM.BLK
  16096.         Include PTRCOM.BLK
  16097.         Include DCLAR4.BLK
  16098. C      DATA NEXPOS /0/
  16099. C      DATA NEXPOT /0/
  16100.       DATA NBLK /1/
  16101. C      DATA SAVBLK /20*0/
  16102. C
  16103. C  SEE IF THE INDEX IS WITHIN RANGE.
  16104. C
  16105.       IF((INDPTR.LT.0).OR.(INDPTR.GT.9)) GO TO 500
  16106.       IF(INDMAX.EQ.0) GO TO 300
  16107.       DO 200 I=1,INDMAX
  16108.       IF(INDNUM(I).EQ.INDPTR) GO TO 400
  16109.   200 CONTINUE
  16110. C
  16111. C  NUMBER HAS NOT BEEN SAVED.
  16112. C
  16113.   300 CONTINUE
  16114.       INDMAX = INDMAX + 1
  16115.       INDNUM(INDMAX) = INDPTR
  16116.   400 CONTINUE
  16117. C
  16118. C  SAVE ALL BLOCKS.
  16119. C
  16120. C  SET THE NUMBER OF WORDS TO SAVE THE POINTERS
  16121. C
  16122. C  TUPLEA 8 (10 ON 32 BIT MACHINES)
  16123. C  TUPLER 9 (13 ON 32 BIT MACHINES)
  16124. C  RIMPTR 6
  16125. C  VARDAT 1+2*NVAR
  16126. C  KEYDAT 1+5*NKEY (1+16*NKEY ON 32 BIT MACHINES)
  16127. C  SRTCOM 3
  16128. C  RULCOM 1 OR 18
  16129. C  WHCOM  6+8*NBOO (+2 IN NBOO NE 0)
  16130. C
  16131. C  TOTALS - 35 + 2*NVAR + 5*NKEY + 8*NBOO + .... (60/64 BIT MACHINES)
  16132. C           41 + 2*NVAR + 16*NKEY + 8*NBOO + ... (32 BIT MACHINES)
  16133. C
  16134.       NVAR = NUMVAR
  16135.       IF(NVAR.GT.5) NVAR = 5
  16136.       NKEY = NUMKEY
  16137.       IF(NKEY.GT.5) NKEY = 5
  16138.       NW = 41
  16139.       NW = NW + 2*NVAR
  16140.       NW = NW + 6*NKEY
  16141.       NW = NW + 8*NBOO
  16142.       IF(RULCNT.NE.0) NW = NW + 17
  16143.       IF(NBOO.NE.0) NW = NW + NEXPOS
  16144.       IF(NBOO.NE.0) NW = NW + NEXPOT
  16145. C
  16146. C  ESTABLISH THE SPACE IN THE POINTER BUFFER
  16147. C
  16148.       I = INDPTR + 1
  16149.       KQ1 = SAVBLK(1,I)
  16150.       IF(KQ1.EQ.0) KQ1 = NBLK
  16151.       IF(NW.EQ.SAVBLK(2,I)) GO TO 420
  16152.       NWO = SAVBLK(2,I)
  16153.       NADD = NW - NWO
  16154.       IF((NBLK+NADD).GT.1000) GO TO 600
  16155.       MOVE = NBLK - (KQ1+NWO)
  16156.       IF(NADD.GT.0) MOVE = -MOVE
  16157.       IF((KQ1+NWO).LT.NBLK)
  16158.      X     CALL BLKMOV(SAVBUF(KQ1+NW),SAVBUF(KQ1+NWO),MOVE)
  16159. C
  16160. C  UPDATE THE INDICES
  16161. C
  16162.       SAVBLK(1,I) = KQ1
  16163.       SAVBLK(2,I) = NW
  16164.       DO 410 K=1,10
  16165.       IF(SAVBLK(1,K).LE.KQ1) GO TO 410
  16166.       SAVBLK(1,K) = SAVBLK(1,K) + NADD
  16167.   410 CONTINUE
  16168.       NBLK = NBLK + NADD
  16169.   420 CONTINUE
  16170. C
  16171. C  THE THE POINTER VALUES TO THE BUFFER
  16172. C
  16173. C TUPLEA
  16174.       NW = 10
  16175.       CALL BLKMOV(SAVBUF(KQ1),ATTNAM,NW)
  16176.       KQ1 = KQ1 + NW
  16177. C TUPLER
  16178.       NW = 13
  16179.       CALL BLKMOV(SAVBUF(KQ1),NAME,NW)
  16180.       KQ1 = KQ1 + NW
  16181. C RIMPTR
  16182.       NW = 6
  16183.       CALL BLKMOV(SAVBUF(KQ1),IVAL,NW)
  16184.       KQ1 = KQ1 + NW
  16185. C VARDAT
  16186.       NW = 1 + NVAR*2
  16187.       CALL BLKMOV(SAVBUF(KQ1),NUMVAR,NW)
  16188.       KQ1 = KQ1 + NW
  16189. C KEYDAT
  16190.       NW = 1 + NKEY*6
  16191.       CALL BLKMOV(SAVBUF(KQ1),NUMKEY,NW)
  16192.       KQ1 = KQ1 + NW
  16193. C SRTCOM
  16194.       SAVBUF(KQ1) = NREAD
  16195.       SAVBUF(KQ1+1) = NSORT
  16196.       CALL BLKMOV(SAVBUF(KQ1+2),FIXLT,1)
  16197.       KQ1 = KQ1 + 3
  16198. C RULCOM
  16199.       NW = 1
  16200.       IF(RULCNT.NE.0) NW = 18
  16201.       CALL BLKMOV(SAVBUF(KQ1),RULCNT,NW)
  16202.       KQ1 = KQ1 + NW
  16203. C  WHCOM
  16204.       SAVBUF(KQ1  ) = NBOO
  16205.       SAVBUF(KQ1+1) = KSTRT
  16206.       SAVBUF(KQ1+2) = MAXTU
  16207.       SAVBUF(KQ1+3) = LIMTU
  16208.       SAVBUF(KQ1+4) = NEXPOS
  16209.       SAVBUF(KQ1+5) = NEXPOT
  16210.       KQ1 = KQ1 + 6
  16211.       IF(NBOO.EQ.0) GO TO 430
  16212.       CALL BLKMOV(SAVBUF(KQ1),BOO,NBOO)
  16213.       KQ1 = KQ1 + NBOO
  16214.       CALL BLKMOV(SAVBUF(KQ1),KATTP,NBOO)
  16215.       KQ1 = KQ1 + NBOO
  16216.       CALL BLKMOV(SAVBUF(KQ1),KATTL,NBOO)
  16217.       KQ1 = KQ1 + NBOO
  16218.       CALL BLKMOV(SAVBUF(KQ1),KATTY,NBOO)
  16219.       KQ1 = KQ1 + NBOO
  16220.       CALL BLKMOV(SAVBUF(KQ1),KOMTYP,NBOO)
  16221.       KQ1 = KQ1 + NBOO
  16222.       CALL BLKMOV(SAVBUF(KQ1),KOMPOS,NBOO)
  16223.       KQ1 = KQ1 + NBOO
  16224.       CALL BLKMOV(SAVBUF(KQ1),KOMLEN,NBOO)
  16225.       KQ1 = KQ1 + NBOO
  16226.       CALL BLKMOV(SAVBUF(KQ1),KOMPOT,NBOO)
  16227.       KQ1 = KQ1 + NBOO
  16228.       CALL BLKMOV(SAVBUF(KQ1),WHRVAL,NEXPOS)
  16229.       KQ1 = KQ1 + NEXPOS
  16230.       CALL BLKMOV(SAVBUF(KQ1),WHRLEN,NEXPOT)
  16231.       KQ1 = KQ1 + NEXPOT
  16232.   430 CONTINUE
  16233.       INDCUR = INDPTR
  16234.       RETURN
  16235.   500 CONTINUE
  16236.       RMSTAT = 70
  16237.       RETURN
  16238.   600 CONTINUE
  16239.       RMSTAT = 71
  16240.       RETURN
  16241.       END
  16242.       SUBROUTINE RMSORT(INDPTR,ANAMES,NUMATT,SORTOR)
  16243.         Include TEXT.BLK
  16244. C
  16245. C  PURPOSE:  FORTRAN INTERFACE ROUTINE TO CALL SOCON TO SORT RIM DATA
  16246. C
  16247. C  PARAMETERS:
  16248. C              INDPTR--MULTIPLE RELATION POSITION POINTER
  16249. C              ANAMES--ARRAY OF ATTRIBUTES TO SORT ON
  16250. C              NUMATT--NUMBER OF ATTRIBUTES TO SORT ON
  16251. C              SORTOR--ARRAY OF ASCENDING OR DESCENDING INDICATORS
  16252. C                      LT 0 - DESCENDING
  16253. C                      GE 0 - ASCENDING
  16254. C
  16255.         Include RMATTS.BLK
  16256.         Include RIMPTR.BLK
  16257.         Include VARDAT.BLK
  16258.         Include WHCOM.BLK
  16259.         Include SRTCOM.BLK
  16260.         Include RIMCOM.BLK
  16261.         Include MISC.BLK
  16262.         Include BUFFER.BLK
  16263.         Include TUPLEA.BLK
  16264.         Include TUPLER.BLK
  16265.         Include PTRCOM.BLK
  16266.         Include INCORE.BLK
  16267.         Include FLAGS.BLK
  16268. C
  16269.       INTEGER INFIL
  16270.       INTEGER OUTFIL
  16271.       LOGICAL SAORD,HERE
  16272.       INTEGER SORTOR(1),INUMB
  16273.         Include DCLAR1.BLK
  16274.       DATA NONUMB /-9999/
  16275.       INUMB = NONUMB
  16276. C
  16277.       RMSTAT = 0
  16278. C         MAKE SURE DB IS DEFINED
  16279. C
  16280.       IF(DFLAG) GOTO 10
  16281.       RMSTAT = 16
  16282.       GOTO 999
  16283. C
  16284.    10 CONTINUE
  16285. C
  16286. C  RESTORE THE NEEDED BLOCKS
  16287. C
  16288.       CALL RMRES(INDPTR)
  16289.       IF(RMSTAT.NE.0) GO TO 999
  16290. C
  16291. C  GET THE ATTRIBUTE DATA
  16292. C
  16293.       NSOVAR = 0
  16294.       DO 800 N=1,NUMATT
  16295.       K = LOCATT(ANAMES(N),NAME)
  16296.       CALL ATTGET(K)
  16297.       IF(K.EQ.0) GO TO 200
  16298.       RMSTAT = 30
  16299.       GO TO 999
  16300. C
  16301. C  SET UP THE ATTRIBUTE SORT DATA
  16302. C
  16303.   200 CONTINUE
  16304.       SAORD = .TRUE.
  16305.       IF(SORTOR(N).LT.0) SAORD = .FALSE.
  16306.       NUMCOL = ATTCOL
  16307. C
  16308. C  CHECK FOR VARIABLE LENGTH - SORTING ON VARIABLE LENGTH
  16309. C  ATTRIBUTES IS CURRENTLY NOT ALLOWED
  16310. C
  16311.       IF(ATTWDS.NE.0) GO TO 300
  16312.       RMSTAT = 80
  16313.       GO TO 999
  16314.   300 CONTINUE
  16315. C
  16316. C  IF TEXT ATTRIBUTE DETERMINE THE NUMBER OF WORDS TO SORT ON - THIS
  16317. C  IS BASED ON THE NUMBER OF CHARACTERS (CURRENTLY 20) AND THE WORD
  16318. C  SIZE.
  16319. C     32 BIT WORDS - 20 CHARACTERS (5 WORDS)
  16320. C     60 BIT WORDS - 20 CHARACTERS (2 WORDS)
  16321. C     64 BIT WORDS - 16 CHARACTERS (2 WORDS)
  16322. C
  16323.       LSL = 1
  16324.       IF(ATTYPE.NE.KZTEXT) GO TO 400
  16325. C
  16326. C  TEXT - DETERMINE SORT WORDS
  16327. C
  16328.       LSL = 20/CHPWD
  16329.       IF(ATTWDS.LT.LSL) LSL = ATTWDS
  16330. C
  16331. C  LOAD THE SORT ARRAYS
  16332. C
  16333.   400 CONTINUE
  16334.       DO 600 K=1,LSL
  16335.       NUMCOL = NUMCOL + 1
  16336.       NSOVAR = NSOVAR + 1
  16337. C
  16338. C  CHECK ON THE NUMBER OF SORT WORDS - CURRENTLY 10
  16339. C  THIS MAY WANT TO BE UPPER FOR THE SMALLER MACHINES
  16340. C
  16341.       IF(NSOVAR.LE.NSORTW) GO TO 500
  16342.       RMSTAT = 81
  16343.       GO TO 999
  16344. C
  16345. C  LOAD ARRAYS
  16346. C
  16347.   500 CONTINUE
  16348.       SORTYP(NSOVAR) = SAORD
  16349.       VARPOS(NSOVAR) = NUMCOL
  16350.       IF(ATTYPE.EQ.KZINT) L=1
  16351.       IF(ATTYPE.EQ.KZREAL) L=2
  16352.       IF(ATTYPE.EQ.KZDOUB) L=3
  16353.       IF(ATTYPE.EQ.KZTEXT) L=4
  16354.       IF(ATTYPE.EQ.KZIVEC) L=1
  16355.       IF(ATTYPE.EQ.KZRVEC) L=2
  16356.       IF(ATTYPE.EQ.KZDVEC) L=3
  16357.       IF(ATTYPE.EQ.KZIMAT) L=1
  16358.       IF(ATTYPE.EQ.KZRMAT) L=2
  16359.       IF(ATTYPE.EQ.KZDMAT) L=3
  16360.       VARTYP(NSOVAR) = L
  16361.   600 CONTINUE
  16362.   800 CONTINUE
  16363. C
  16364. C  DO THE SORT.
  16365. C  OPEN THE INPUT SORT FILE
  16366. C
  16367.       INFIL = 20
  16368.       OPEN(INFIL,FILE='SORTFIL.DAT',ACCESS='SEQUENTIAL',
  16369.      &  FORM='UNFORMATTED', STATUS='NEW',IOSTAT=IOS)
  16370.       IF(IOS.NE.0)STOP 'CANNOT OPEN SORTFIL.DAT -- STOPPING'
  16371. C
  16372. C  SET UP TUPLE LIMITS - SAVE USER SPECIFIED LIMIT
  16373. C
  16374.       LIMTUS = LIMTU
  16375.       LIMTU = ALL9S
  16376. C
  16377. C  WRITE THE COMPLETE TUPLE AND CID ON THE SORT FILE
  16378. C
  16379. C  CHECK FOR VARIABLE LENGTH TUPLES IN THE RELATION
  16380. C
  16381.       FIXLT = .TRUE.
  16382.       IF(NUMVAR.GT.0) FIXLT = .FALSE.
  16383. C
  16384. C  INITIALIZE THE REMAINING VARIABLES
  16385. C
  16386.       LTUMAX = 0
  16387.       LTUMIN = ALL9S
  16388.       NSORT = 0
  16389.       LTUPLE = 0
  16390.       IF(FIXLT) LTUPLE = NCOL + 1
  16391. C
  16392. C  READ IN THE TUPLES AND WRITE THE SORT FILE
  16393. C
  16394.  1200 CONTINUE
  16395.       CALL RMLOOK(IP,1,1,LEN)
  16396.       IF(RMSTAT.NE.0) GO TO 1400
  16397.       LENX = LEN + 1
  16398.       NSORT = NSORT + 1
  16399.       IP = IP - 1
  16400.       IF(FIXLT) GO TO 1300
  16401. C
  16402. C  VARIBLE LENGTH TUPLE
  16403. C
  16404.       LTUPLE = LTUPLE + LENX
  16405.       IF(LENX.GT.LTUMAX) LTUMAX = LENX
  16406.       IF(LENX.LT.LTUMIN) LTUMIN = LENX
  16407.       WRITE(INFIL) LENX,CID,(BUFFER(IP+K),K=1,LEN)
  16408.       GO TO 1200
  16409. C
  16410. C  FIXED LENGTH TUPLES
  16411. C
  16412.  1300 CONTINUE
  16413.       WRITE(INFIL) CID,(BUFFER(IP+K),K=1,LEN)
  16414.       GO TO 1200
  16415. C
  16416. C  CHECK THAT SOME TUPLES WERE WRITTIN ON INFIL
  16417. C  RESET THE TUPLE LIMIT
  16418. C
  16419.  1400 CONTINUE
  16420.       RMSTAT = 0
  16421.       LIMTU = LIMTUS
  16422.       IF(NSORT.GT.0) GO TO 1420
  16423.       RMSTAT = -1
  16424.       GO TO 998
  16425. C
  16426. C  OPEN THE OUTPUT FILES
  16427. C
  16428.  1420 CONTINUE
  16429.       OUTFIL = 20
  16430.       IF(INDPTR.EQ.0) GO TO 1430
  16431.       OUTFIL = INFIL + INDPTR
  16432.  1430 CONTINUE
  16433. C
  16434. C  CLEAR OUT ANY PAGE DATA LEFT IN BUFFER
  16435. C
  16436.       CALL BLKCLN
  16437. C
  16438. C  FIXUP THE LENGTHS FOR VARIABLE LENGTH STUFF
  16439. C
  16440.       IF(FIXLT) GO TO 1440
  16441.       LTUPLE = LTUPLE + NSORT
  16442.       LTUMAX = LTUMAX + 1
  16443.       LTUMIN = LTUMIN + 1
  16444. C
  16445. C  CALL SWCON TO DO THE ACTUAL SORT
  16446. C
  16447.  1440 CONTINUE
  16448.       IERR = 0
  16449.       CALL SWCON(BUFFER,LIMIT,INFIL,OUTFIL,IERR)
  16450.       IF(IERR.EQ.0) GO TO 1450
  16451.       RMSTAT = 89
  16452.       GO TO 998
  16453. C
  16454.  1450 CONTINUE
  16455. C
  16456. C  INITIALIZE THE BUFFER AND RESAVE THE POINTERS
  16457. C
  16458.       NS = 1
  16459.       CALL RMGTSO(IP,10,-1,LEN,INDPTR)
  16460.       CALL RMSAV(INDCUR)
  16461. C
  16462.   998 CONTINUE
  16463.       IF(INDPTR.EQ.0) GO TO 999
  16464. C
  16465. C  CLOSE THE SORT INPUT FILE
  16466. C
  16467.       CLOSE(INFIL,STATUS='DELETE')
  16468.   999 CONTINUE
  16469.       RETURN
  16470.       END
  16471.       SUBROUTINE RMSTRT
  16472.         Include TEXT.BLK
  16473. C
  16474. C  PURPOSE:   INITIALIZE ALL NEEDED VARIABLES AND ARRAYS
  16475. C
  16476.         Include RMATTS.BLK
  16477.         Include CONST4.BLK
  16478.         Include CONST8.BLK
  16479.         Include FLAGS.BLK
  16480.         Include MISC.BLK
  16481.         Include RELTBL.BLK
  16482.         Include ATTBLE.BLK
  16483.         Include INCORE.BLK
  16484.         Include F1COM.BLK
  16485.         Include F2COM.BLK
  16486.         Include F3COM.BLK
  16487.         Include RULCOM.BLK
  16488.         Include RIMPTR.BLK
  16489.         Include SRTCOM.BLK
  16490. C
  16491. C  CALL THE RMCONS ROUTINE TO INITIALIZE THE HOLLERITH CONSTANTS
  16492. C  THIS CALL IS MADE ONLY ONCE PER EXECUTION
  16493. C
  16494.       DATA KALTST /0/
  16495.       IF(KALTST.EQ.1) GO TO 100
  16496.       CALL RMCONS
  16497.       KALTST = 1
  16498.   100 CONTINUE
  16499. C
  16500. C  SET FLAGS AND VARIABLES.
  16501. C
  16502. C  /MISC/
  16503.       ALL9S = 999999999
  16504.       CHPWD = 4
  16505.       MAXCOL = 1021
  16506. C  /FLAGS/
  16507.       DFLAG = .FALSE.
  16508.       OWNER = NONE
  16509.       IFMOD = .FALSE.
  16510.       TOL = 0.
  16511.       PCENT = .FALSE.
  16512.       RUCK = .TRUE.
  16513. C  /RELTBL/
  16514.       CNAME = BLANK
  16515.       LRROW = 0
  16516.       NRROW = 74
  16517.       RELMOD = 0
  16518.       RPBUF = 73
  16519. C  /ATTBLE/
  16520.       CANAME = BLANK
  16521.       CRNAME = BLANK
  16522.       CRSTRT = 0
  16523.       CROW = 0
  16524.       LROW = 0
  16525.       NAROW = 227
  16526.       ATTMOD = 0
  16527.       APBUF = 113
  16528. C  /INCORE/
  16529.       CALL ZEROIT(BLOCKS(1,1),60)
  16530.       NEXT = 1
  16531.       LIMIT = 4608
  16532.       NUMBL = 0
  16533. C  /F1COM/
  16534.       FILE1 = 31
  16535.       LENBF1 = 1024
  16536.       LF1REC = 0
  16537.       CAREC = 0
  16538.       CRREC = 0
  16539. C  /F2COM/
  16540.       FILE2 = 32
  16541.       LENBF2 = 1024
  16542.       DO 200 I=1,3
  16543.       CURBLK(I) = 0
  16544.       MODFLG(I) = 0
  16545.   200 CONTINUE
  16546. C  /F3COM/
  16547.       FILE3 = 33
  16548.       LENBF3 = 126
  16549.       MAXIC = 20
  16550. C  /RIMPTR/
  16551.       IVAL = 0
  16552.       CID = 0
  16553.       NID = 0
  16554.       NS = 0
  16555.       MID = 0
  16556.       INDCUR = NULL
  16557.       INDMAX = 0
  16558. C  /SRTCOM/
  16559.       NSORTW = 10
  16560.       FIXLT = .TRUE.
  16561.       NSORT = 0
  16562.       NREAD = 0
  16563. C  /RULCOM/
  16564.       RIMRRC = K8RRC
  16565.       RIMRDT = K8RDT
  16566.       RULCNT = 0
  16567.       RETURN
  16568.       END
  16569.       SUBROUTINE RMTIME(IT)
  16570.         Include TEXT.BLK
  16571. C
  16572. C  PURPOSE:   RETURN THE CURRENT TIME
  16573. C
  16574. C  PARAMETERS:
  16575. C         IT------THE CURRENT TIME IN HH.MM.SS FORMAT
  16576. C
  16577.         Include MISC.BLK
  16578.     CHARACTER*10 CCIT
  16579.     REAL*8 ZIT
  16580.     EQUIVALENCE(CCIT,ZIT)
  16581.         REAL*8 IT
  16582. C    CHARACTER*8 CITT
  16583. C    REAL*8 CIR
  16584. C    EQUIVALENCE(CIR,CITT)
  16585. C    DATA CITT/'12:00:00'/
  16586.     CALL SYSTIM(ZIT)
  16587.     IT=ZIT
  16588. C    IT=CIR
  16589.       CALL PUTT(IT,3,46)
  16590. C DUMMY TIME CALL - JUST SAY NOON
  16591.       CALL PUTT(IT,6,46)
  16592. C 46 IS ASCII DECIMAL POINT (PERIOD)
  16593.       RETURN
  16594.       END
  16595.       SUBROUTINE RMTOL(VAL,PERC)
  16596.         Include TEXT.BLK
  16597. C
  16598. C  PURPOSE:  SET THE TOLERANCE VARIABLES IN THE FORTRAN INTERFACE
  16599. C
  16600. C  PARAMETERS: VAL----TOLERANCE VALUE - ABSOLUTE VALUE OR PERCENT
  16601. C              PERC---PERC = 0 -- VAL IS ABSOLUTE VALUE
  16602. C                     PERC = 1 -- VAL IS PERCENT
  16603. C
  16604.         Include FLAGS.BLK
  16605.       INTEGER PERC
  16606. C
  16607.       TOL = VAL
  16608.       PCENT = .FALSE.
  16609.       IF(PERC.EQ.0) GO TO 999
  16610. C
  16611. C  PERCENTAGE
  16612. C
  16613.       TOL = VAL/100.
  16614.       PCENT = .TRUE.
  16615.   999 CONTINUE
  16616.       RETURN
  16617.       END
  16618.       SUBROUTINE RMUSER(ID)
  16619.         Include TEXT.BLK
  16620. C
  16621. C  PURPOSE:   SET THE CURRENT USERID TO THE USER SUPPLIED ID
  16622. C
  16623.         Include FLAGS.BLK
  16624.         Include MISC.BLK
  16625.       INTEGER ID(1)
  16626. C
  16627. C  SET THE USERID TO ID.
  16628. C
  16629.       USERID = BLANK
  16630.       CALL STRMOV(ID,1,8,USERID,1)
  16631.       RETURN
  16632.       END
  16633.       SUBROUTINE RMVARC(CTYP,TUPVAL)
  16634.         Include TEXT.BLK
  16635. C
  16636. C  PURPOSE: THIS ROUTINE CHANGES THE VARIABLE LENGTH ATTRIBUTE
  16637. C           TUPLE HEADERS FROM INTERNAL TO USER REPRESENTATION
  16638. C           OR VISA VERSA.
  16639. C
  16640. C                             USER                    INTERNAL
  16641. C           TYPE        WORD1       WORD2       WORD1       WORD2
  16642. C           ----------  ----------  ----------  ----------  ----------
  16643.  
  16644. C           TEXT        CHARACTERS  0           WORDS       CHARACTERS
  16645. C           INT         ITEMS       0           WORDS       1
  16646. C           REAL        ITEMS       0           WORDS       1
  16647. C           DOUBLE      ITEMS       0           WORDS       1
  16648. C           VECTORS     ITEMS       0           WORDS       1
  16649. C           MATRICES    ROWS        COLS        WORDS       ROWS
  16650. C
  16651. C  PARAMETERS:
  16652. C           CTYP-----CONVERSION TYPE - -1 = INTERNAL TO USER
  16653. C                                      +1 = USER TO INTERNAL
  16654. C           TUPVAL---ARRAY CONTAINING THE TUPLE VALUES
  16655. C
  16656.         Include RMATTS.BLK
  16657.         Include VARDAT.BLK
  16658.         Include RIMCOM.BLK
  16659.         Include TUPLER.BLK
  16660.         Include TUPLEA.BLK
  16661.         Include MISC.BLK
  16662. C
  16663.       INTEGER CTYP
  16664.       INTEGER TUPVAL(1)
  16665. C
  16666. C  IF THE NUMBER OF VARIABLE ATTRIBUTES EXCEEDS 5 WE HAVE TO USE
  16667. C  ATTGET ETC TO DO THE CONVERSION ----
  16668. C
  16669.       LOOP = NUMVAR
  16670.       IF(NUMVAR.LE.5) GO TO 100
  16671. C
  16672. C  MORE THAN 5 VARIABLE LENGTH ATTRIBUTES
  16673. C
  16674.       I = LOCATT(BLANK,NAME)
  16675.       LOOP = NATT
  16676. C
  16677. C  GET THE VALUES FOR EACH VARIABLE LENGTH ATTRIBUTE
  16678. C
  16679.   100 CONTINUE
  16680.       DO 500 K=1,LOOP
  16681.       IF(NUMVAR.LE.5) GO TO 200
  16682.       CALL ATTGET(ISTATX)
  16683.       IF(ISTATX.NE.0) GO TO 999
  16684.       IF(ATTWDS.NE.0) GO TO 500
  16685.       IP = TUPVAL(ATTCOL)
  16686.       ITYPE = ATTYPE
  16687.       GO TO 300
  16688.   200 CONTINUE
  16689.       IP = TUPVAL(POSVAR(1,K))
  16690.       ITYPE = POSVAR(2,K)
  16691.   300 CONTINUE
  16692.       IF((IP.LT.1).OR.(IP.GT.MAXCOL)) GO TO 998
  16693.       IW1 = TUPVAL(IP)
  16694.       IW2 = TUPVAL(IP+1)
  16695.       IF(CTYP.LT.0) GO TO 400
  16696. C
  16697. C  USER TO INTERNAL - RMPUT,RMLOAD
  16698. C
  16699.       IF(ITYPE.EQ.KZINT ) TUPVAL(IP) = IW1
  16700.       IF(ITYPE.EQ.KZREAL) TUPVAL(IP) = IW1
  16701.       IF(ITYPE.EQ.KZDOUB) TUPVAL(IP) = 2*IW1
  16702.       IF(ITYPE.EQ.KZTEXT) TUPVAL(IP) = (IW1-1)/CHPWD + 1
  16703.       IF(ITYPE.EQ.KZIVEC) TUPVAL(IP) = IW1
  16704.       IF(ITYPE.EQ.KZRVEC) TUPVAL(IP) = IW1
  16705.       IF(ITYPE.EQ.KZDVEC) TUPVAL(IP) = 2*IW1
  16706.       IF(ITYPE.EQ.KZIMAT) TUPVAL(IP) = IW1*IW2
  16707.       IF(ITYPE.EQ.KZRMAT) TUPVAL(IP) = IW1*IW2
  16708.       IF(ITYPE.EQ.KZDMAT) TUPVAL(IP) = 2*IW1*IW2
  16709.       TUPVAL(IP+1) = 1
  16710.       IF(ITYPE.EQ.KZTEXT) TUPVAL(IP+1) = IW1
  16711.       IF(ITYPE.EQ.KZIMAT) TUPVAL(IP+1) = IW1
  16712.       IF(ITYPE.EQ.KZRMAT) TUPVAL(IP+1) = IW1
  16713.       IF(ITYPE.EQ.KZDMAT) TUPVAL(IP+1) = IW1
  16714.       IF((TUPVAL(IP).LT.1).OR.(TUPVAL(IP).GT.MAXCOL)) GO TO 998
  16715.       GO TO 500
  16716. C
  16717. C  INTERNAL TO USER - RMGET
  16718. C
  16719.   400 CONTINUE
  16720.       IF(ITYPE.EQ.KZINT ) TUPVAL(IP) = IW1
  16721.       IF(ITYPE.EQ.KZREAL) TUPVAL(IP) = IW1
  16722.       IF(ITYPE.EQ.KZDOUB) TUPVAL(IP) = IW1/2
  16723.       IF(ITYPE.EQ.KZTEXT) TUPVAL(IP) = IW2
  16724.       IF(ITYPE.EQ.KZIVEC) TUPVAL(IP) = IW1
  16725.       IF(ITYPE.EQ.KZRVEC) TUPVAL(IP) = IW1
  16726.       IF(ITYPE.EQ.KZDVEC) TUPVAL(IP) = IW1/2
  16727.       IF(ITYPE.EQ.KZIMAT) TUPVAL(IP) = IW2
  16728.       IF(ITYPE.EQ.KZRMAT) TUPVAL(IP) = IW2
  16729.       IF(ITYPE.EQ.KZDMAT) TUPVAL(IP) = IW2
  16730.       TUPVAL(IP+1) = 0
  16731.       IF(ITYPE.EQ.KZIMAT) TUPVAL(IP+1) = IW1/IW2
  16732.       IF(ITYPE.EQ.KZRMAT) TUPVAL(IP+1) = IW1/IW2
  16733.       IF(ITYPE.EQ.KZDMAT) TUPVAL(IP+1) = (IW1/2)/IW2
  16734.   500 CONTINUE
  16735.       GO TO 999
  16736. C
  16737.   998 RMSTAT = 100
  16738. C
  16739.   999 CONTINUE
  16740.       RETURN
  16741.       END
  16742.       SUBROUTINE RMWHER(INDPTR,ANAMES,OPERS,VALS,NUMVAL,NXTBOO,NUMBOO)
  16743.         Include TEXT.BLK
  16744. C
  16745. C  PURPOSE:  PROCESS A RIM WHERE CLAUSE IN THE FORTRAN INTERFACE
  16746. C
  16747. C  PARAMETERS:
  16748. C        INDPTR---MULTIPLE RELATION POSITION INDICATOR
  16749. C        ANAMES---ARRAY OF ATTRIBUTE NAMES
  16750. C        OPERS----ARRAY OF OPERATORS
  16751. C        VALS-----ARRAY OF CONDITION VALUES
  16752. C                   FIXED LENGTH - VSET1,VSET2,.....
  16753. C                   VARIABLE LENGTH ------
  16754. C                     TEXT  (NCHAR1)(0)VSET1,(NCHAR2)(0)VSET2,....
  16755. C                     INT,REAL,DOUB, AND VECTORS (ITEMS1)(0)VSET1,...
  16756. C                     MATRICES (ROWS1)(COLS1)VSET1,(ROWS2)(COLS2)VSET2,.
  16757. C        NUMVAL---NUMBER OF VALUE SETS (VSETS) IN VALS
  16758. C        NXTBOO---ARRAY OF "AND" "OR" OPERATORS
  16759. C        NUMBOO---NUMBER OF WHERE CONDITIONS (ROW DIMENSION
  16760. C                 OF ALL ARRAYS)
  16761. C
  16762.         Include FLAGS.BLK
  16763.         Include RMATTS.BLK
  16764.         Include CONST4.BLK
  16765.         Include CONST8.BLK
  16766.         Include MISC.BLK
  16767.         Include RIMCOM.BLK
  16768.         Include TUPLEA.BLK
  16769.         Include TUPLER.BLK
  16770.         Include WHCOM.BLK
  16771.         Include RIMPTR.BLK
  16772.         Include PTRCOM.BLK
  16773. C
  16774.       LOGICAL IFVAR
  16775.       LOGICAL IFLIM
  16776.       LOGICAL IFTUP
  16777.       INTEGER OPERS(1)
  16778.       INTEGER VALS(NUMBOO,1)
  16779.       INTEGER NUMVAL(1)
  16780.       INTEGER NXTBOO(1)
  16781.       INTEGER IDUM(2)
  16782.         Include DCLAR1.BLK
  16783. C
  16784. C
  16785. C  MAKE SURE DB IS OPEN
  16786. C
  16787.       IF(DFLAG) GO TO 10
  16788.       RMSTAT = 16
  16789.       GO TO 9999
  16790. C
  16791.    10 CONTINUE
  16792. C  CHECK THE NUMBER OF OPERATORS
  16793. C
  16794.       IF(NUMBOO.LE.10) GO TO 100
  16795.       RMSTAT = 40
  16796.       GO TO 9999
  16797. C
  16798. C  RESTORE THE REQUIRED BLOCKS
  16799. C
  16800.   100 CONTINUE
  16801.       RMSTAT = 0
  16802.       CALL RMRES(INDPTR)
  16803.       IF(RMSTAT.NE.0) GO TO 9999
  16804. C
  16805. C  INITIALIZE
  16806. C
  16807.       NS = 0
  16808.       NTUPC = 0
  16809.       KMM = 0
  16810.       KSTRT = 0
  16811.       MAXTU = 0
  16812.       LIMTU = ALL9S
  16813. C
  16814. C  BREAK UP EACH CONDITION.
  16815. C
  16816.       DO 600 I=1,10
  16817.       KOMPOS(I) = 0
  16818.       KOMPOT(I) = 0
  16819.       KOMLEN(I) = 0
  16820.       KATTP(I) = 0
  16821.       KATTL(I) = 0
  16822.       KATTY(I) = 0
  16823.   600 CONTINUE
  16824.       NBOO = 1
  16825.       BOO(1) = K4AND
  16826.       NEXPOT = 1
  16827.       NEXPOS = 1
  16828.       DO 2000 K=1,NUMBOO
  16829. C
  16830. C  GET THE ATTRIBUTE.
  16831. C
  16832.       IFLIM = .FALSE.
  16833.       IF(ANAMES(K).NE.K8LIM) GO TO 1150
  16834. C
  16835. C     LIMIT KEYWORD
  16836. C
  16837.       IF(OPERS(K).EQ.K4EQ) GO TO 700
  16838.       RMSTAT = 41
  16839.       GO TO 9999
  16840.   700 CONTINUE
  16841.       LIMTU = VALS(K,1)
  16842.       IF((LIMTU.GT.0).AND.(LIMTU.LT.ALL9S)) GO TO 800
  16843.       RMSTAT = 41
  16844.       GO TO 9999
  16845.   800 CONTINUE
  16846.       NBOO = NBOO - 1
  16847.       IFLIM = .TRUE.
  16848.       GO TO 1800
  16849.  1150 CONTINUE
  16850.       IFTUP = .FALSE.
  16851.       IF(ANAMES(K).EQ.K8ROWS) IFTUP = .TRUE.
  16852.       IF(.NOT.IFTUP) GO TO 1190
  16853. C
  16854. C  ROW WHERE CLAUSE - CHECK TYPE AND GET MAXIMUM ROW NUMBER
  16855. C
  16856.       NTUPC = NTUPC + 1
  16857.       MAXTUN = VALS(K,1)
  16858.       IF(MAXTUN.GT.MAXTU) MAXTU = MAXTUN
  16859.       KOMPAR = OPERS(K)
  16860.       KOMTYP(NBOO) = LOCBOO(KOMPAR)
  16861.       IF(KOMTYP(NBOO).NE.0) GO TO 1170
  16862. C
  16863. C  UNRECOGNIZED BOOLEAN COMPARISION.
  16864. C
  16865.       RMSTAT = 42
  16866.       GO TO 9999
  16867.  1170 CONTINUE
  16868.       IF((KOMTYP(NBOO).GE.3).AND.(KOMTYP(NBOO).LE.5)) MAXTU = NTUPLE
  16869.       GO TO 1500
  16870.  1190 CONTINUE
  16871.       I = LOCATT(ANAMES(K),NAME)
  16872.       IF(I.NE.0) GO TO 1200
  16873.       CALL ATTGET(I)
  16874.       IF(I.EQ.0) GO TO 1300
  16875. C
  16876. C  UNRECOGNIZED ATTRIBUTE.
  16877. C
  16878.  1200 CONTINUE
  16879.       RMSTAT = 30
  16880.       GO TO 9999
  16881.  1300 CONTINUE
  16882.       KATTP(NBOO) = ATTCOL
  16883.       KATTL(NBOO) = ATTLEN
  16884.       CALL TYPER(ATTYPE,MATVEC,KATTY(NBOO))
  16885. C
  16886. C  DETERMINE THE TYPE OF BOOLEAN EXPRESSION.
  16887. C
  16888.       KOMPAR = OPERS(K)
  16889.       KOMTYP(NBOO) = LOCBOO(KOMPAR)
  16890.       IF(KOMTYP(NBOO).NE.0) GO TO 1500
  16891. C
  16892. C  UNRECOGNIZED BOOLEAN COMPARISION.
  16893. C
  16894.       RMSTAT = 42
  16895.       GO TO 9999
  16896.  1500 CONTINUE
  16897. C
  16898. C  CHECK FOR FAILS OR EXISTS AND EQS ONLY ON TEXT ATTRIBUTES
  16899. C
  16900.       IF(KOMTYP(NBOO).LE.1) GO TO 1800
  16901.       IF(KOMTYP(NBOO).GE.10) GO TO 1600
  16902.       IF(KOMTYP(NBOO).NE.9) GO TO 1510
  16903.       IF(ATTYPE.EQ.KZTEXT) GO TO 1510
  16904.       RMSTAT = 43
  16905.       GO TO 9999
  16906. C
  16907. C     CHECK FOR "WHERE XXX EQ MIN OR MAX"
  16908. C
  16909.  1510 CONTINUE
  16910.       ITEMP = VALS(K,1)
  16911.       KMM = 0
  16912.       IF((ITEMP.EQ.K4MIN).OR.(ITEMP.EQ.K4MAX)) KMM = ITEMP
  16913.       IF(KMM.EQ.0) GO TO 1550
  16914. C
  16915. C  WE HAVE A MIN/MAX SPECIFICATION - CHECK SYNTAX
  16916. C
  16917.       IF((KOMTYP(NBOO).LT.2).OR.(KOMTYP(NBOO).GT.7)) GO TO 1550
  16918.       IF(ATTYPE.EQ.KZTEXT) GO TO 1550
  16919.       IF(ATTYPE.EQ.KZINT ) GO TO 1530
  16920.       IF(ATTYPE.EQ.KZREAL) GO TO 1530
  16921.       IF(ATTYPE.EQ.KZDOUB) GO TO 1530
  16922. C
  16923. C  ILLEGAL ATTRIBUTE FOR USE WITH MIN/MAX.
  16924. C
  16925.       RMSTAT = 44
  16926.       GO TO 9999
  16927.  1530 CONTINUE
  16928.       IF(ATTLEN.EQ.1) GO TO 1540
  16929.       IF((ATTLEN.EQ.2).AND.(ATTYPE.EQ.KZDOUB)) GO TO 1540
  16930. C
  16931. C  ILLEGAL USE OF MULTI-WORD ATTRIBUTE WITH MIN/MAX.
  16932. C
  16933.       RMSTAT = 44
  16934.       GO TO 9999
  16935.  1540 CONTINUE
  16936. C
  16937. C     SET NBOO AND LIMTU TO FOOL RMLOOK FOR MINMAX
  16938. C
  16939.       MNBOO = NBOO
  16940.       MLIMTU = LIMTU
  16941.       NBOO = 0
  16942.       LIMTU = ALL9S
  16943.       KOMPOS(MNBOO) = NEXPOS
  16944.       CALL MINMAX(WHRVAL(NEXPOS),KMM)
  16945.       IF(RMSTAT.NE.0) GO TO 9999
  16946.       NEXPOS = NEXPOS + ATTLEN
  16947.       KOMPOT(MNBOO) = NEXPOT
  16948.       WHRLEN(NEXPOT) = ATTLEN
  16949.       NEXPOT = NEXPOT + 1
  16950.       LIMTU = MLIMTU
  16951.       NBOO = MNBOO
  16952. C
  16953. C  RESET RELATION POINTERS
  16954. C
  16955.       I = LOCREL(NAME)
  16956.       IF(I.EQ.0) GO TO 1545
  16957.       RMSTAT = 20
  16958.       GO TO 9999
  16959.  1545 CONTINUE
  16960.       KOMLEN(NBOO) = 1
  16961.       IF(K.EQ.NUMBOO) GO TO 2100
  16962.       IF((NXTBOO(K).NE.K4AND).AND.(NXTBOO(K).NE.K4OR)) GO TO 8000
  16963.       NBOO = NBOO + 1
  16964.       BOO(NBOO) = NXTBOO(K)
  16965.       GO TO 2000
  16966.  1550 CONTINUE
  16967. C
  16968. C  VALUE COMPARISON. MAKE SURE THE VALUE LOOKS GOOD.
  16969. C
  16970.       IFVAR = .FALSE.
  16971.       CALL ITOH(NR,NW,KATTL(NBOO))
  16972.       IF((.NOT.IFTUP).AND.(NW.EQ.0)) IFVAR = .TRUE.
  16973.       IF(KATTY(NBOO).EQ.0) NW = 1
  16974.       ITYPE = ATTYPE
  16975.       IF(KATTY(NBOO).EQ.0) ITYPE = KZINT
  16976.       KOMPOS(NBOO) = NEXPOS
  16977.       KOMPOT(NBOO) = NEXPOT
  16978. C
  16979. C  TRANSFER VALUES FROM VALS TO WHRVAL
  16980. C
  16981.       II = 0
  16982.       LOOP = NUMVAL(K)
  16983.       IF(LOOP.EQ.1) GO TO 1551
  16984.       IF(KOMTYP(NBOO).EQ.2) GO TO 1551
  16985.       IF(KOMTYP(NBOO).EQ.3) GO TO 1551
  16986.       IF(KOMTYP(NBOO).EQ.9) GO TO 1551
  16987.       RMSTAT = 47
  16988.       GO TO 9999
  16989.  1551 CONTINUE
  16990.       DO 1560 KK=1,LOOP
  16991.       IF(.NOT.IFVAR) GO TO 1552
  16992. C
  16993. C  VARIABLE LENGTH TUPLES
  16994. C
  16995.       NW = 0
  16996.       II = II + 1
  16997.       IF(ITYPE.EQ.KZINT ) NW = VALS(K,II)
  16998.       IF(ITYPE.EQ.KZREAL) NW = VALS(K,II)
  16999.       IF(ITYPE.EQ.KZDOUB) NW = 2*VALS(K,II)
  17000.       IF(ITYPE.EQ.KZTEXT) NW = (VALS(K,II)-1)/CHPWD + 1
  17001.       IF(ITYPE.EQ.KZIVEC) NW = VALS(K,II)
  17002.       IF(ITYPE.EQ.KZRVEC) NW = VALS(K,II)
  17003.       IF(ITYPE.EQ.KZDVEC) NW = 2*VALS(K,II)
  17004.       IF(ITYPE.EQ.KZIMAT) NW = VALS(K,II)*VALS(K,II+1)
  17005.       IF(ITYPE.EQ.KZRMAT) NW = VALS(K,II)*VALS(K,II+1)
  17006.       IF(ITYPE.EQ.KZDMAT) NW = 2*VALS(K,II)*VALS(K,II+1)
  17007.       NR = 0
  17008.       IF(ITYPE.EQ.KZTEXT) NR = VALS(K,II)
  17009.       IF(ITYPE.EQ.KZIMAT) NR = VALS(K,II)
  17010.       IF(ITYPE.EQ.KZRMAT) NR = VALS(K,II)
  17011.       IF(ITYPE.EQ.KZDMAT) NR = VALS(K,II)
  17012.       II = II + 1
  17013. C
  17014. C  LOAD RTHE ARRAYS
  17015. C
  17016.  1552 CONTINUE
  17017.       DO 1554 I=1,NW
  17018.       II = II + 1
  17019.       WHRVAL(NEXPOS) = VALS(K,II)
  17020.       IF(.NOT.IFTUP) GO TO 1553
  17021.       IF(WHRVAL(NEXPOS).GT.MAXTU) MAXTU = WHRVAL(NEXPOS)
  17022.       IF((WHRVAL(NEXPOS).GT.0).AND.(WHRVAL(NEXPOS).LE.MAXCOL))
  17023.      X       GO TO 1553
  17024.       RMSTAT = 48
  17025.       GO TO 9999
  17026.  1553 CONTINUE
  17027.       NEXPOS = NEXPOS + 1
  17028.  1554 CONTINUE
  17029.       IF(KOMTYP(NBOO).NE.9) GO TO 1558
  17030. C
  17031. C  EQS - GET THE NUMBER OF CHARACTERS
  17032. C
  17033.       IK = II + 1
  17034.       DO 1556 I=1,NW
  17035.       IK = IK - 1
  17036.       IF(VALS(K,IK).EQ.IBLANK) GO TO 1556
  17037.       KPO = NSCAN(VALS(K,IK),CHPWD,-CHPWD,BLANK,1,1)
  17038.       NR = (NW-I)*CHPWD + KPO
  17039.       GO TO 1558
  17040.  1556 CONTINUE
  17041.  1558 CONTINUE
  17042.       CALL HTOI(NR,NW,WHRLEN(NEXPOT))
  17043.       NEXPOT = NEXPOT + 1
  17044.  1560 CONTINUE
  17045.       IF(K.EQ.NUMBOO) GO TO 2000
  17046.       KOMLEN(NBOO) = NUMVAL(K)
  17047.       IF((NXTBOO(K).NE.K4AND).AND.(NXTBOO(K).NE.K4OR)) GO TO 8000
  17048.       NBOO = NBOO + 1
  17049.       BOO(NBOO) = NXTBOO(K)
  17050.       GO TO 2000
  17051. C
  17052. C  ATTRIBUTE COMPARISON. CHECK FOR LEGAL ATTRIBUTE
  17053. C
  17054.  1600 CONTINUE
  17055. C
  17056. C  MESSY CODE SO THAT WE CAN MOVE 8 CHARACTERS ON ANY MACHINE
  17057. C
  17058.       IDUM(1) = VALS(K,1)
  17059.       IF(CHPWD.LT.8) IDUM(2) = VALS(K,2)
  17060.       ANAME = BLANK
  17061.       CALL STRMOV(IDUM(1),1,8,ANAME,1)
  17062.       I = LOCATT(ANAME,NAME)
  17063.       IF(I.NE.0) GO TO 1200
  17064.       CALL ATTGET(I)
  17065.       KOMPOS(NBOO) = ATTCOL
  17066.       IF((ATTLEN.EQ.KATTL(NBOO)).AND.(ATTYPE.EQ.KATTY(NBOO)))
  17067.      X     GO TO 1800
  17068.       RMSTAT = 46
  17069.       GO TO 9999
  17070.  1800 CONTINUE
  17071. C
  17072. C  LOOK FOR THE NEXT BOOLEAN JOIN.
  17073. C
  17074.       IF(K.EQ.NUMBOO) GO TO 2000
  17075.       IF((NXTBOO(K).NE.K4AND).AND.(NXTBOO(K).NE.K4OR)) GO TO 8000
  17076.       IF(.NOT.IFLIM) KOMLEN(NBOO) = 1
  17077. C
  17078. C  GET NEXT OPERATION
  17079. C
  17080.       NBOO = NBOO + 1
  17081.       BOO(NBOO) = NXTBOO(K)
  17082.  2000 CONTINUE
  17083. C
  17084. C  GET THE LENGTH OF THE LIST IN THE LAST CONDITION
  17085. C
  17086.       IF(IFLIM) GO TO 2100
  17087.       KOMLEN(NBOO) = NUMVAL(NUMBOO)
  17088.       IF(KOMTYP(NBOO).LE.1) KOMLEN(NBOO) = 1
  17089.       IF(KOMLEN(NBOO).LE.1) GO TO 2100
  17090. C
  17091. C  WE HAVE A LIST - VALID ONLY FOR EQ AND NE
  17092. C
  17093.       IF(KOMTYP(NBOO).EQ.2) GO TO 2005
  17094.       IF(KOMTYP(NBOO).EQ.3) GO TO 2005
  17095.       IF(KOMTYP(NBOO).EQ.9) GO TO 2005
  17096.       RMSTAT = 47
  17097.       GO TO 9999
  17098. C
  17099. C  ROW WHERE CLAUSE - CHECK TYPE AND GET MAXIMUM ROW NUMBER
  17100. C
  17101.  2005 CONTINUE
  17102.       IF(.NOT.IFTUP) GO TO 2100
  17103.       LOOP = KOMLEN(NBOO)
  17104.       DO 2010 I=2,LOOP
  17105.       MAXTUN = VALS(NUMBOO,I)
  17106.       IF(MAXTUN.GT.MAXTU) MAXTU = MAXTUN
  17107.  2010 CONTINUE
  17108. C
  17109. C  CHECK FOR KEY PROCESSING
  17110. C
  17111.  2100 CONTINUE
  17112.       BOO(1) = K4AND
  17113.       IF(NTUPC.NE.NBOO) MAXTU = 0
  17114.       IF(BOO(NBOO).NE.K4AND) GO TO 9998
  17115.       IF(KOMTYP(NBOO).NE.2) GO TO 9998
  17116.       IF(IFTUP) GO TO 9998
  17117.       IF(KOMLEN(NBOO).NE.1) GO TO 9998
  17118. C
  17119. C  USE KEY PROCESSING.
  17120. C
  17121.       KSTRT = ATTKEY
  17122.       IF(KSTRT.NE.0) NS = 2
  17123.       GO TO 9998
  17124. C
  17125. C  UNABLE TO PROCESS THE WHERE CLAUSE.
  17126. C
  17127.  8000 CONTINUE
  17128.       RMSTAT = 45
  17129.       GO TO 9999
  17130. C
  17131. C  EXIT.
  17132. C
  17133.  9998 CONTINUE
  17134.       IF(MAXTU.EQ.0) MAXTU = ALL9S
  17135.       CALL WHETOL
  17136.  9999 CONTINUE
  17137.       RETURN
  17138.       END
  17139.       SUBROUTINE RMZIP
  17140.       RETURN
  17141.       END
  17142.       SUBROUTINE RNAMEA(IATT)
  17143.         Include TEXT.BLK
  17144. C
  17145. C     IATT....=2 IF COMMAND IS "RENAME ATTRIBUTE....."
  17146. C             =1 IF KEYWORD ATTRIBUTE IS OMITTED
  17147. C
  17148. C     THIS ROUTINE PROCESSES RENAME ATTRIBUTE COMMAND
  17149. C     STEP 1. CHECK SYNTAX
  17150. C     STEP 2. SEE IF NEWATT ALREADY EXISTS.
  17151. C             IF SO, CHECK THAT IT IS NOT IN SAME RELATION WITH
  17152. C             OLDATT AND THAT TYPE AND LENGTH AGREE WITH OLDATT.
  17153. C     STEP 3. LOOP ON ATTGET FOR ALL RELATIONS
  17154. C               CHECK PERMISSION.
  17155. C               RENAME
  17156. C               COUNT RENAMES
  17157. C     STEP 4. RENAME ATTRIBUTES IN RULES RELATION
  17158. C             ATTRIBUTE IS CHANGING NAMES IN ALL RELATIONS.
  17159. C             LOOP THRU CSCRTBL AND CHANGE.
  17160. C
  17161.         Include CONST8.BLK
  17162.         Include RMKEYW.BLK
  17163.         Include CONST4.BLK
  17164.         Include FILES.BLK
  17165.         Include TUPLEA.BLK
  17166.         Include BUFFER.BLK
  17167.         Include MISC.BLK
  17168.         Include DCLAR1.BLK
  17169.         Include DCLAR6.BLK
  17170.         Include WHCOM.BLK
  17171.         Include RIMCOM.BLK
  17172.         Include RIMPTR.BLK
  17173.       LOGICAL CHANGE
  17174.       LOGICAL NE,EQ,EQKEYW
  17175.       INTEGER STATUS
  17176.    10 CONTINUE
  17177. C
  17178. C     CHECK SYNTAX
  17179. C
  17180.       ITEMS = LXITEM(DUM)
  17181.       IF(.NOT.EQKEYW(IATT+2,KWTO,2)) GO TO 8100
  17182.       IF((ITEMS.GT.3+IATT).AND.(.NOT.EQKEYW(4+IATT,KWIN,2))) GO TO 8100
  17183.       IF((ITEMS.NE.3+IATT).AND.(ITEMS.NE.5+IATT)) GO TO 8100
  17184.       ANAME1 = BLANK
  17185.       ANAME2 = BLANK
  17186.       CALL LXSREC(1+IATT,1,8,ANAME1,1)
  17187.       CALL LXSREC(3+IATT,1,8,ANAME2,1)
  17188.       IF((LXLENC(3+IATT).GE.1).AND.(LXLENC(3+IATT).LE.8)) GO TO 20
  17189. C
  17190. C     WARNING - NEW ATTRIBUTE NAME IS LONGER THAN 8 CHARS.
  17191. C
  17192.       CALL WARN(7,KWATTR,K4E)
  17193.       GO TO 9999
  17194.    20 CONTINUE
  17195. C
  17196. C     SCAN FOR FROM OR IN
  17197. C
  17198.       RNAME1 = BLANK
  17199.       IFLAG = 0
  17200.       J = LFIND(1,ITEMS,KWIN,2)
  17201.       IF(J.EQ.0)J = LFIND(1,ITEMS,KWFROM,4)
  17202.       IF(J.EQ.0) GO TO 100
  17203. C
  17204. C     SPECIFIED RELATION
  17205. C
  17206.       IFLAG = 1
  17207.       CALL LXSREC(J+1,1,8,RNAME1,1)
  17208. C
  17209. C  CHECK THAT RELATION EXISTS
  17210. C
  17211.       I = LOCREL(RNAME1)
  17212.       IF(I.EQ.0) GO TO 100
  17213.       CALL WARN(1,RNAME1,BLANK)
  17214.       GO TO 9999
  17215.   100 CONTINUE
  17216. C
  17217. C     SEE IF ANAME1 EXISTS
  17218. C
  17219.       I = LOCATT(ANAME1,RNAME1)
  17220.       IF(I.NE.0) GO TO 8200
  17221. C
  17222. C     SEE IF ANAME2 ALREADY EXISTS
  17223. C
  17224.       I = LOCATT(ANAME2,BLANK )
  17225.       IF(I.NE.0) GO TO 200
  17226. C
  17227. C     EXISTS - CHECK TYPE AND LENGTH
  17228. C
  17229.       CALL ATTGET(STATUS)
  17230.       ILEN = ATTLEN
  17231.       ITYPE = ATTYPE
  17232.       I = LOCATT(ANAME1,RNAME1)
  17233.       CALL ATTGET(STATUS)
  17234.       IF(ILEN.NE.ATTLEN) GO TO 8300
  17235.       IF(ITYPE.NE.ATTYPE) GO TO 8300
  17236. C
  17237. C     NOW CHAECK THAT OLD AND NEW DON'T COHABITATE IN SAME RELATION
  17238. C
  17239.       NUM = 0
  17240.   120 CONTINUE
  17241.       NUM = NUM + 1
  17242.       I = LOCATT(ANAME1,RNAME1)
  17243.       DO 130 II=1,NUM
  17244.       CALL ATTGET(STATUS)
  17245.       IF(STATUS.NE.0) GO TO 200
  17246.   130 CONTINUE
  17247.       I = LOCATT(ANAME2,RELNAM)
  17248.       IF(I.NE.0) GO TO 120
  17249.       WRITE (NOUT,140) ANAME2,RELNAM
  17250.   140 FORMAT(19H -ERROR- ATTRIBUTE ,A8,
  17251.      X       28H ALREADY EXISTS IN RELATION ,A8)
  17252.       GO TO 9999
  17253.   200 CONTINUE
  17254. C
  17255. C     RENAME ATTRIBUTE
  17256. C
  17257.       I = LOCATT(ANAME1,RNAME1)
  17258.       NUMT = 0
  17259.   210 CONTINUE
  17260.       CALL ATTGET(STATUS)
  17261.       IF(STATUS.NE.0) GO TO 300
  17262. C
  17263. C     CHECK FOR PERMISSION
  17264. C
  17265.       I = LOCREL(RELNAM)
  17266.       I = LOCPRM(RELNAM,2)
  17267.       IF(I.EQ.0) GO TO 220
  17268.       IF(IFLAG.EQ.1) GO TO 8400
  17269.       GO TO 210
  17270.   220 CONTINUE
  17271.       NUMT = NUMT + 1
  17272.       IF(NUMT.LE.10) NAMES(NUMT) = RELNAM
  17273.       ATTNAM = ANAME2
  17274.       CALL ATTPUT(STATUS)
  17275.       IF(IFLAG.NE.1) GO TO 210
  17276.   300 CONTINUE
  17277.       WRITE (NOUT,305)ANAME1,NUMT
  17278.   305 FORMAT(11H ATTRIBUTE ,A8,12H RENAMED IN ,I4,10H RELATIONS)
  17279. C
  17280. C     NOW FOR THE NASTY NASTY RULES
  17281. C
  17282.       I = LOCREL(K8RDT  )
  17283.       IF(I.NE.0) GO TO 9999
  17284. C
  17285. C     LOOP THRU RMRULRRC AND CHANGE
  17286. C
  17287.       NS = 0
  17288.       NBOO = 0
  17289.       LIMTU = ALL9S
  17290.       NUMR = 0
  17291.   310 CONTINUE
  17292.       CALL RMLOOK(LOC,1,1,LENGTH)
  17293.       IF(RMSTAT.NE.0) GO TO 9997
  17294.       CHANGE = .FALSE.
  17295.       IF(NE(BUFFER(LOC+3),ANAME1)) GO TO 320
  17296.       IF((IFLAG.EQ.1).AND.(NE(BUFFER(LOC+5),RNAME1))) GO TO 320
  17297.       IF(NUMT.GT.10) GO TO 318
  17298.       DO 315 I=1,NUMT
  17299.       IF(EQ(NAMES(I),BUFFER(LOC+5))) GO TO 318
  17300.   315 CONTINUE
  17301.       GO TO 320
  17302.   318 CONTINUE
  17303.       CHANGE = .TRUE.
  17304.       CALL STRMOV(ANAME2,1,8,BUFFER(LOC+3),1)
  17305.       NUMR = NUMR + 1
  17306.   320 CONTINUE
  17307.       IF(NE(BUFFER(LOC+10),ANAME1)) GO TO 330
  17308.       IF((IFLAG.EQ.1).AND.(NE(BUFFER(LOC+12),RNAME1))) GO TO 330
  17309.       IF(NUMT.GT.10) GO TO 328
  17310.       DO 325 I=1,NUMT
  17311.       IF(EQ(NAMES(I),BUFFER(LOC+12))) GO TO 328
  17312.   325 CONTINUE
  17313.       GO TO 330
  17314.   328 CONTINUE
  17315.       CHANGE = .TRUE.
  17316.       CALL STRMOV(ANAME2,1,8,BUFFER(LOC+10),1)
  17317.       NUMR = NUMR + 1
  17318.   330 CONTINUE
  17319.       IF(CHANGE)CALL PUTDAT(1,CID,BUFFER(LOC),LENGTH)
  17320.       GO TO 310
  17321.  8100 CONTINUE
  17322. C
  17323. C     BAD SYNTAX
  17324. C
  17325.       CALL WARN(4,0,0)
  17326.       GO TO 9999
  17327.  8200 CONTINUE
  17328. C
  17329. C     ANAME1 NOT THERE
  17330. C
  17331.       WRITE (NOUT,9200)ANAME1
  17332.  9200 FORMAT(19H -ERROR- ATTRIBUTE ,A8,
  17333.      X       29H IS NOT AN EXISTING ATTRIBUTE )
  17334.       GO TO 9999
  17335.  8300 CONTINUE
  17336. C
  17337. C     TYPE/LENGTH DIFFERS
  17338. C
  17339.       WRITE (NOUT,9300)ANAME2,ANAME1
  17340.  9300 FORMAT(19H -ERROR- ATTRIBUTE ,A8,
  17341.      X       35H EXISTS - TYPE/LENGTH DIFFERS FROM ,A8)
  17342.       GO TO 9999
  17343.  8400 CONTINUE
  17344.       WRITE (NOUT,9400)
  17345.  9400 FORMAT(39H -ERROR- UNAUTHORIZED ACCESS FOR RENAME )
  17346.       GO TO 9999
  17347.  9997 CONTINUE
  17348.       WRITE(NOUT,9998) ANAME1,NUMR
  17349.  9998 FORMAT(11H ATTRIBUTE ,A8,12H RENAMED IN ,I3,
  17350.      X       20H PLACES IN THE RULES)
  17351.       GO TO 9999
  17352. C
  17353. C     ALL DONE
  17354. C
  17355.  9999 CONTINUE
  17356.       RETURN
  17357.       END
  17358.       SUBROUTINE RNAMER
  17359.         Include TEXT.BLK
  17360. C
  17361. C     SUBROUTINE TO RENAME A RELATION INCLUDING SUCH
  17362. C     NASTIES AS CHANGING THE RULES.
  17363. C
  17364.         Include RMATTS.BLK
  17365.         Include RMKEYW.BLK
  17366.         Include CONST8.BLK
  17367.         Include RIMPTR.BLK
  17368.         Include RIMCOM.BLK
  17369.         Include TUPLEA.BLK
  17370.         Include TUPLER.BLK
  17371.         Include ATTBLE.BLK
  17372.         Include START.BLK
  17373.         Include BUFFER.BLK
  17374.         Include FILES.BLK
  17375.         Include MISC.BLK
  17376.         Include DCLAR1.BLK
  17377.         Include DCLAR6.BLK
  17378.         Include WHCOM.BLK
  17379.       LOGICAL EQKEYW
  17380.       LOGICAL NE,EQ
  17381.       ITEMS = LXITEM(IDUM)
  17382.       IF(ITEMS.NE.5) GO TO 4000
  17383.       IF(.NOT.EQKEYW(4,KWTO,2)) GO TO 4000
  17384.       IF((LXLENC(5).GE.1).AND.(LXLENC(5).LE.8)) GO TO 2000
  17385.       CALL WARN(7,KWRELA,BLANK)
  17386.       GO TO 9999
  17387.  2000 CONTINUE
  17388.       NAMNEW = BLANK
  17389.       CALL LXSREC(5,1,8,NAMNEW,1)
  17390.       I = LOCREL(NAMNEW)
  17391.       IF(I.NE.0) GO TO 4150
  17392. C
  17393. C  NEW NAME IS A DUPLICATE.
  17394. C
  17395.       WRITE(NOUT,9008)
  17396.  9008 FORMAT(44H -ERROR- DUPLICATE RELATION NAME ENCOUNTERED)
  17397.       GO TO 9999
  17398.  4150 CONTINUE
  17399.       RNAME = BLANK
  17400.       CALL LXSREC(3,1,8,RNAME,1)
  17401.       I = LOCREL(RNAME)
  17402.       IF(I.EQ.0) GO TO 4200
  17403.       CALL WARN(1,RNAME,0)
  17404.       GO TO 9999
  17405.  4200 CONTINUE
  17406.       I = LOCPRM(NAME,2)
  17407.       IF(I.EQ.0) GO TO 4250
  17408. C
  17409. C     FAILS MODIFY PERMISSION
  17410. C
  17411.       WRITE (NOUT,5)
  17412.     5 FORMAT(39H -ERROR- UNAUTHORIZED ACCESS FOR RENAME )
  17413.       GO TO 9999
  17414.  4250 CONTINUE
  17415. C
  17416. C  CHANGE EVERYTHING NEEDED FOR THE RELATION.
  17417. C
  17418.       CALL RELGET(ISTAT)
  17419.       NAMNEW = BLANK
  17420.       CALL LXSREC(5,1,8,NAMNEW,1)
  17421.       NAME = NAMNEW
  17422.       CALL RELPUT
  17423.       I = LOCATT(BLANK,RNAME)
  17424.       IF(I.NE.0) GO TO 9999
  17425.  4300 CONTINUE
  17426.       CALL ATTGET(ISTAT)
  17427.       IF(ISTAT.NE.0) GO TO 4400
  17428.       RELNAM = NAMNEW
  17429.       CALL ATTPUT(ISTAT)
  17430.       GO TO 4300
  17431.  4400 CONTINUE
  17432.       WRITE(NOUT,9009) RNAME,NAMNEW
  17433.  9009 FORMAT(10H RELATION ,A8,12H RENAMED TO ,A8)
  17434. C
  17435. C     CHECK FOR RULES AND RENAME THEM
  17436. C
  17437.       I = LOCREL(K8RRC  )
  17438.       IF(I.NE.0) GO TO 9999
  17439.       NS = 0
  17440.       NBOO = 0
  17441.       LIMTU = ALL9S
  17442. C
  17443. C     LOOP THRU RMRULRRC AND CHANGE
  17444. C
  17445.  5000 CONTINUE
  17446.       CALL RMLOOK(LOC,1,1,LENGTH)
  17447.       IF(RMSTAT.NE.0) GO TO 5500
  17448.       IF(NE(BUFFER(LOC),RNAME)) GO TO 5000
  17449.       CALL STRMOV(NAMNEW,1,8,BUFFER(LOC),1)
  17450.       CALL PUTDAT(1,CID,BUFFER(LOC),LENGTH)
  17451.       GO TO 5000
  17452.  5500 CONTINUE
  17453. C
  17454. C     LOOP THRU RMRULRDT AND CHANGE
  17455. C
  17456.       I = LOCREL(K8RDT  )
  17457.       IF(I.NE.0) GO TO 9999
  17458.       NS = 0
  17459.       NBOO = 0
  17460.       LIMTU = ALL9S
  17461.  5600 CONTINUE
  17462.       CALL RMLOOK(LOC,1,1,LENGTH)
  17463.       IF(RMSTAT.NE.0) GO TO 9999
  17464.       IFLAG = 0
  17465.       IF(NE(BUFFER(LOC+5),RNAME)) GO TO 5700
  17466.       IFLAG = 1
  17467.       CALL STRMOV(NAMNEW,1,8,BUFFER(LOC+5),1)
  17468.  5700 CONTINUE
  17469.       IF(NE(BUFFER(LOC+12),RNAME)) GO TO 5800
  17470.       IFLAG = 1
  17471.       CALL STRMOV(NAMNEW,1,8,BUFFER(LOC+12),1)
  17472.  5800 CONTINUE
  17473.       IF(IFLAG.EQ.0) GO TO 5600
  17474.       CALL PUTDAT(1,CID,BUFFER(LOC),LENGTH)
  17475.       GO TO 5600
  17476. C
  17477. C     SYNTAX ERRORS
  17478. C
  17479.  4000 CONTINUE
  17480.       CALL WARN(4,0,0)
  17481.       GO TO 9999
  17482.  9999 CONTINUE
  17483.       RETURN
  17484.       END
  17485.       REAL FUNCTION ROUN(REAL,NUMC,EF)
  17486.         Include TEXT.BLK
  17487. C
  17488. C     RETURN A ROUNDED VERSION OF THE REAL NUMBER
  17489. C     TO FIT IN NUMC CHARACTERS.  IF REAL IS NEGATIVE
  17490. C     REDUCE NUMC BY ONE.
  17491. C
  17492.       LOGICAL EF
  17493.       NUM = NUMC
  17494.       IF(REAL.LT.0.)NUM = NUM - 1
  17495.       ROUN = REAL
  17496.       IF(REAL.EQ.0.) RETURN
  17497.       IE = IEXP(REAL)
  17498.       IF((.NOT.EF).AND.(IE.LT.0)) IE = 0
  17499.       V = .5
  17500.       IF(REAL.LT.0.) V = -.5
  17501.       ROUN = REAL + V*(10.**(IE-NUM))
  17502.       RETURN
  17503.       END
  17504.       SUBROUTINE RTOC(STRING,CHAR1,NUM,VEAL)
  17505.         Include TEXT.BLK
  17506. C
  17507. C     THIS ROUTINE TRIES TO DETERMINE THE BEST F FORMAT FOR
  17508. C     A REAL NUMBER AND CALL RTOF TO CHARACTERIZE IT.
  17509. C
  17510.       INTEGER STRING(1)
  17511.       LOGICAL EF
  17512.       EF = .FALSE.
  17513.       REAL = ROUN(VEAL,NUM-1,EF)
  17514.       NUM1 = NUM
  17515.       NUM2 = NUM1 - 2
  17516.       IF(REAL.EQ.0.) GO TO 10
  17517.  
  17518.       NP = IEXP(REAL)
  17519.       N = NUM - 1
  17520.       IF(REAL.LT.0.) N = N - 1
  17521.       NUM2 = N - NP
  17522.       IF(NP.GE.0) GO TO 10
  17523.       NUM2 = N
  17524.       IF(IABS(NP).GT.NUM-2) NUM2 = 0
  17525.    10 CONTINUE
  17526.       CALL RTOF(STRING,CHAR1,NUM1,NUM2,VEAL)
  17527.       RETURN
  17528.       END
  17529.       SUBROUTINE RTOF(STRING,CHAR1,NUM1,NUM2,VEAL)
  17530.         Include TEXT.BLK
  17531. C
  17532. C     THIS ROUTINE CONVERTS A REAL NUMBER TO CHARACTERS AND
  17533. C     PUTS THE RESULT IN STRING.  FIRST IT TRYS TO FIT THE
  17534. C     NUMBER INTO FX.Y FORMAT WHERE X IS NUM1 AND Y IS NUM2.
  17535. C     IF THE NUMBER WONT FIT (I.E. NO SIGNIFICANT DIGITS WILL
  17536. C     MAKE IT), IT TRYS TO MAKE AN E FORMAT IN THE SAME SPACE.
  17537. C     IF THAT FAILS THE FIELD IS FILLED WITH ASTERISKS.
  17538. C
  17539. C     STRING....REPOSITORY FOR CHARACTERS
  17540. C     CHAR1.....STARTING POINT IN STRING
  17541. C     NUM1......FIELD WIDTH
  17542. C     NUM2......SPACE AFTER DECIMAL POINT
  17543. C     VEAL......A REAL NUMBER
  17544. C
  17545.         Include CONST4.BLK
  17546.         Include MISC.BLK
  17547.       INTEGER STRING(1),CHAR1,ZERO
  17548.       LOGICAL EF
  17549.       EF = .FALSE.
  17550.       REAL = ROUN(VEAL,NUM1-1,EF)
  17551.       IERR = 0
  17552.       R = ABS(REAL)
  17553.       IN1 = INT(REAL)
  17554.       POINT = R - FLOAT(INT(R))
  17555.       NUM = NUM1 - NUM2 - 1
  17556.       IF(REAL.EQ.0.) GO TO 20
  17557.       IF(NUM.LT.0) GO TO 1000
  17558.       IF(NUM2.LT.0) GO TO 1000
  17559.       IF(NUM2.GT.NUM1) GO TO 1000
  17560.       IF(REAL.LT.0.) NUM = NUM - 1
  17561.       NUMM = -((NUM2+1)/2)
  17562.       IF(R.GE.10.**NUM ) GO TO 1000
  17563.       IF(R.LT.10.**NUMM) GO TO 1000
  17564.       IF(REAL.LT.0.) NUM = NUM + 1
  17565. C
  17566. C     FITS IN F FORMAT
  17567. C
  17568.    20 CONTINUE
  17569.       IF(NUM.GT.0) CALL ITOC(STRING,CHAR1,NUM,IN1,IERR)
  17570.       IF((NUM.EQ.1).AND.(REAL.LT.0.))CALL PUTT(STRING,CHAR1,K4MNUS)
  17571.       IF(IERR.NE.0) GO TO 1000
  17572.       CALL PUTT(STRING,CHAR1+NUM,K4DOT)
  17573.       IF(NUM2.EQ.0) GO TO 200
  17574.       POINT = POINT * 10.**NUM2
  17575.       IN1 = INT(POINT)
  17576.       CALL ITOC(STRING,CHAR1+NUM+1,NUM2,IN1,IERR)
  17577.       IF(IERR.NE.0) GO TO 1000
  17578. C
  17579. C     MAKE BLANKS AFTER THE DECIMAL POINT INTO ZEROS
  17580. C
  17581.       IL = CHAR1 + NUM + 1
  17582.       MAX = CHAR1 + NUM1 - 1
  17583.    50 CONTINUE
  17584.       IF(IL.GT.MAX) GO TO 200
  17585.       CALL GETT(STRING,IL,IC)
  17586.       IF(IC.NE.IBLANK) GO TO 200
  17587.       CALL PUTT(STRING,IL,K40)
  17588.       IL = IL + 1
  17589.       GO TO 50
  17590.   200 CONTINUE
  17591. C
  17592. C     CHANGE TRAILING ZEROS TO BLANKS
  17593. C
  17594.       NUM = CHAR1 + NUM1
  17595.       DO 250 I=1,NUM1
  17596.       NUM = NUM - 1
  17597.       CALL GETT(STRING,NUM,IC)
  17598.       IF(IC.NE.K40) GO TO 9999
  17599.       CALL PUTT(STRING,NUM,IBLANK)
  17600.   250 CONTINUE
  17601.       GO TO 9999
  17602.  1000 CONTINUE
  17603.       N = 4
  17604.       IF(ABS(REAL).LE.1.E+10) N = 3
  17605.       EF = .TRUE.
  17606.       REAL = ROUN(VEAL,NUM1-N,EF)
  17607. C
  17608. C      E - FORMAT
  17609. C
  17610.       MIN = 5
  17611.       IF(REAL.LT.0.) MIN = MIN + 1
  17612.       IF(NUM1.LT.MIN) GO TO 2000
  17613.       NUM = NUM1
  17614.       IC = CHAR1
  17615.       IF(REAL.GE.0) GO TO 1020
  17616.       CALL PUTT(STRING,IC,K4MNUS)
  17617.       IC = IC + 1
  17618.       NUM = NUM - 1
  17619.  1020 CONTINUE
  17620.       CALL PUTT(STRING,IC,K4DOT)
  17621.       IC = IC + 1
  17622.       NUM = NUM - 1
  17623. C
  17624. C     FIND THE INTEGER AND THE EXPONENT
  17625. C
  17626.       IE = IEXP(REAL)
  17627.       RR = ABS(REAL)/(10.**IE)
  17628.       IE = IE - 1
  17629.  1200 CONTINUE
  17630.       NUME = 1
  17631.       IF(IABS(IE).GE.10) NUME = 2
  17632.       IF(IABS(IE).GE.100) NUME = 3
  17633.       NUMI = NUM - NUME - 1
  17634.       IN1 = INT(RR*(10.**NUMI))
  17635.       CALL ITOC(STRING,IC,NUMI,IN1,IERR)
  17636.       IF(IERR.NE.0) GO TO 2000
  17637.       IC = IC + NUMI
  17638.       CALL PUTT(STRING,IC,K4PLUS)
  17639.       IF(IE.LT.0)CALL PUTT(STRING,IC,K4MNUS)
  17640.       IC = IC + 1
  17641.       CALL ITOC(STRING,IC,NUME,IABS(IE),IERR)
  17642.       IF(IERR.NE.0) GO TO 2000
  17643. C
  17644. C     SWITCH THE FIRST TWO CHARACTERS
  17645. C     I.E. X.XXX+YY RATHER THAN .XXXX+ZZ
  17646. C
  17647.       NUM = CHAR1
  17648.       IF(REAL.LT.0.) NUM = NUM + 1
  17649.       CALL GETT(STRING,NUM,IC1)
  17650.       CALL GETT(STRING,NUM+1,IC2)
  17651.       CALL PUTT(STRING,NUM,IC2)
  17652.       CALL PUTT(STRING,NUM+1,IC1)
  17653.       GO TO 9999
  17654.  2000 CONTINUE
  17655. C
  17656. C     STAR FILL
  17657. C
  17658.       CALL FILCH(STRING,CHAR1,NUM1,K4STAR)
  17659.  9999 CONTINUE
  17660.       RETURN
  17661.       END
  17662.       SUBROUTINE RULDEL(RNAME,NUMRUL)
  17663.         Include TEXT.BLK
  17664. C
  17665. C  PURPOSE: THIS ROUTINE PROCESSES A DELETE RULE COMMAND
  17666. C
  17667. C  PARAMETERS
  17668. C         RNAME---RULE RELATION - RIMRRC OR RIMRDT
  17669. C         NUMREL--RULE NUMBER TO DELETE
  17670.         Include CONST4.BLK
  17671.         Include CONST8.BLK
  17672.         Include TUPLER.BLK
  17673.         Include TUPLEA.BLK
  17674.         Include RIMCOM.BLK
  17675.         Include RIMPTR.BLK
  17676.         Include FILES.BLK
  17677.         Include WHCOM.BLK
  17678.         Include MISC.BLK
  17679.         Include DCLAR1.BLK
  17680.       LOGICAL EQ
  17681. C
  17682.       NDP = 0
  17683.       ND = 0
  17684. C
  17685. C  CHECK IF A RULE NUMBER WAS ENTERED
  17686. C
  17687.       IF(NUMRUL.GT.0) GO TO 40
  17688.       CALL WARN(4,0,0)
  17689.       RMSTAT = 110
  17690.       GO TO 9999
  17691.    40 CONTINUE
  17692. C
  17693. C  SET UP THE RELATION DATA
  17694. C
  17695.       I = LOCREL(RNAME)
  17696.       IF(I.EQ.0) GO TO 100
  17697.    50 WRITE(NOUT,9000)
  17698.  9000 FORMAT(29H -WARNING- RULES DO NOT EXIST  )
  17699.       RMSTAT = 110
  17700.       GO TO 9999
  17701. C
  17702. C  SET UP THE WHERE CLAUSE.
  17703. C
  17704.   100 CONTINUE
  17705.       NBOO = 0
  17706.       I = LOCATT(K8NUM,RNAME)
  17707.       IF(I.NE.0) GO TO 50
  17708.       CALL ATTGET(I)
  17709.       IF(I.NE.0) GO TO 50
  17710.       NBOO = 1
  17711.       BOO(1) = K4AND
  17712.       KATTP(1) = ATTCOL
  17713.       KATTL(1) = ATTLEN
  17714.       KATTY(1) = ATTYPE
  17715.       KOMTYP(1) = 2
  17716.       KOMPOS(1) = 1
  17717.       KOMLEN(1) = 1
  17718.       KOMPOT(1) = 1
  17719.       KSTRT = 0
  17720.       MAXTU = ALL9S
  17721.       LIMTU = ALL9S
  17722.       WHRVAL(1) = NUMRUL
  17723.       WHRLEN(1) = 1
  17724.       NS = 0
  17725. C
  17726. C  SEQUENCE THROUGH THE DATA DELETING TUPLES.
  17727. C
  17728.       IF(NTUPLE.LE.0) GO TO 9999
  17729.       IID = CID
  17730.   200 CONTINUE
  17731.       CALL RMLOOK(MAT,1,1,LENGTH)
  17732.       IF(RMSTAT.NE.0) GO TO 700
  17733. C
  17734. C  DELINK THIS TUPLE.
  17735. C
  17736.       CALL DELDAT(1,CID)
  17737.       IF(CID.EQ.IID) IID = NID
  17738.       ND = ND + 1
  17739.       NDP = 1
  17740.       GO TO 200
  17741. C
  17742. C  CHANGE THE STARTING ID IF NEEDED.
  17743. C
  17744.   700 CONTINUE
  17745.       CALL RELGET(ISTAT)
  17746.       RSTART = IID
  17747.       NTUPLE = NTUPLE - ND
  17748.       CALL RELPUT
  17749.       RMSTAT = 0
  17750.       IF(ND.NE.0) GO TO 9999
  17751.       WRITE(NOUT,8001) NUMRUL
  17752.  8001 FORMAT(15H -WARNING- RULE,I4,15H DOES NOT EXIST)
  17753.       RMSTAT = 110
  17754.  9999 CONTINUE
  17755.       IF(EQ(K8RDT,RNAME)) WRITE(NOUT,9001) NDP
  17756.  9001 FORMAT(2X,I6,14H RULES DELETED )
  17757. C
  17758. C  DONE.
  17759. C
  17760.       RETURN
  17761.       END
  17762.       SUBROUTINE RULES
  17763.         Include TEXT.BLK
  17764. C
  17765. C  THE PURPOSE OF THIS ROUTINE IS TO INVOKE A ROUTINE TO
  17766. C  PRINT OUT ALL RULES PERTAINING TO A RIM SCHEMA IF SUCH
  17767. C  RULES EXIST.
  17768. C
  17769.         Include CONST8.BLK
  17770.         Include FILES.BLK
  17771.         Include WHCOM.BLK
  17772.         Include FLAGS.BLK
  17773.         Include RIMCOM.BLK
  17774.         Include MISC.BLK
  17775.       LOGICAL EQ
  17776.       INTEGER RRC(3)
  17777.       INTEGER OLDNUM
  17778.       INTEGER RULENO
  17779. C
  17780.       IF(EQ(USERID,OWNER)) GO TO 100
  17781.       WRITE(NOUT,9000)
  17782.  9000 FORMAT(20H -ERROR- YOU ARE NOT,
  17783.      X       33H AUTHORIZED TO LOOK AT THE RULES )
  17784.       GO TO 999
  17785.   100 CONTINUE
  17786. C
  17787. C  LOOK FOR THE RULE RELATION CORRESPONDENCE TABLE.
  17788. C
  17789.       I = LOCREL(K8RRC)
  17790.       IF(I.EQ.0) GO TO 200
  17791.       WRITE(NOUT,9001)
  17792.  9001 FORMAT(45H -WARNING- NO RULES DEFINED FOR THIS DATABASE )
  17793.       GO TO 999
  17794. C
  17795. C  CYCLE THROUGH THE RULES.
  17796. C
  17797.   200 CONTINUE
  17798.       OLDNUM = 0
  17799.       NBOO = 0
  17800.       LIMTU = ALL9S
  17801.   300 CONTINUE
  17802.       CALL RMLOOK(RRC,2,0,LEN)
  17803.       IF(RMSTAT.NE.0) GO TO 999
  17804.       NUMRUL = RRC(3)
  17805.       IF(NUMRUL.EQ.OLDNUM) GO TO 300
  17806. C
  17807. C  CALL PRULE TO DUMP OUT THE RULES.
  17808. C
  17809.       CALL PRULE(NUMRUL)
  17810.       OLDNUM = NUMRUL
  17811.       GO TO 300
  17812. C
  17813. C  DONE.
  17814. C
  17815.   999 CONTINUE
  17816.       RETURN
  17817.       END
  17818.       FUNCTION RXREC(I)
  17819.         Include TEXT.BLK
  17820. C
  17821. C     THIS FUNCTION RETURNS THE REAL VALUE OF A REAL ITEM.
  17822. C
  17823.         Include LXCARD.BLK
  17824.         Include LXCON.BLK
  17825.       RXREC = 0.
  17826.       IF(I.LT.1) RETURN
  17827.       IF(I.GT.NEWN) RETURN
  17828.       IF(TYPE(I).NE.REAL) RETURN
  17829.       RXREC = RVAL(I)
  17830.       RETURN
  17831.       END
  17832.       SUBROUTINE SELECT
  17833.         Include TEXT.BLK
  17834. C
  17835. C     THIS ROUTINE HANDLES THE SELECT COMMAND.
  17836. C
  17837.         Include RMATTS.BLK
  17838.         Include CONST4.BLK
  17839.         Include PROM.BLK
  17840.         Include BUFFER.BLK
  17841.         Include BLNKFL.BLK
  17842.         Include TUPLER.BLK
  17843.         Include FILES.BLK
  17844.         Include MISC.BLK
  17845.         Include RIMCOM.BLK
  17846.         Include RIMPTR.BLK
  17847.         Include SELCOM.BLK
  17848.       LOGICAL DONE,ADONE
  17849.       LOGICAL ITALLY
  17850. C
  17851. C     SET LPP AND MCPL
  17852. C
  17853.       LPP = 10000000
  17854.       IF(.NOT.CONNO) LPP = 56
  17855.       MCPL = 78
  17856.       IF(.NOT.CONNO)MCPL = 132
  17857.       IF(ULPP.NE.0) LPP = ULPP
  17858.       IF(UMCPL.NE.0) MCPL = UMCPL
  17859. C
  17860. C     CALL SELPAR TO SET SELCOM BLOCK
  17861. C
  17862.       ITALLY = .FALSE.
  17863.       CALL SELPAR(ITALLY)
  17864.       IF(NUMATT.LE.0) GO TO 900
  17865.       NLINE = 3
  17866.       WRITE (NOUTR,30)
  17867.       CALL SPOUT(TITLE,MCPL)
  17868.       CALL SPOUT(MINUS,MCPL)
  17869.    30 FORMAT(1H )
  17870. C
  17871. C  OPEN THE SORT FILE IF WE HAVE "SORTED BY ....... "
  17872. C
  17873.       LENGTH = NCOL
  17874.       IF(NS.EQ.1) CALL GTSORT(IP,1,-1,LENGTH)
  17875. C
  17876. C     LOOP ON RECORDS
  17877. C
  17878.    50 CONTINUE
  17879.       IF(NS.EQ.1) CALL GTSORT(IP,1,1,LENGTH)
  17880.       IF(NS.NE.1) CALL RMLOOK(IP,1,1,LENGTH)
  17881.       IF(RMSTAT.NE.0) GO TO 9999
  17882.       DO 55 II=1,NUMATT
  17883.       CURPOS(II) = 1
  17884.    55 CONTINUE
  17885. C
  17886. C     SET UP VARIABLE LENGTH ATTRIBUTES
  17887. C
  17888.       DO 60 I=1,NUMATT
  17889.       IF(.NOT.VAR(I)) GO TO 60
  17890.       JP = IP + FP(I) - 1
  17891.       JP = BUFFER(JP) + IP - 1
  17892.       LEN(I) = BUFFER(JP)
  17893.       IF(ATYPE(I).EQ.KZTEXT) LEN(I) = BUFFER(JP+1)
  17894.       IF(ATYPE(I).EQ.KZDOUB) LEN(I) = LEN(I)/2
  17895.       IF(ATYPE(I).EQ.KZDVEC) LEN(I) = LEN(I)/2
  17896.       IF(ATYPE(I).EQ.KZDMAT) LEN(I) = LEN(I)/2
  17897.       ROWD(I) = BUFFER(JP+1)
  17898.       IF(ATYPE(I).EQ.KZIMAT) COLD(I) = LEN(I)/ROWD(I)
  17899.       IF(ATYPE(I).EQ.KZRMAT) COLD(I) = LEN(I)/ROWD(I)
  17900.       IF(ATYPE(I).EQ.KZDMAT) COLD(I) = LEN(I)/ROWD(I)
  17901.    60 CONTINUE
  17902. C
  17903. C     LOOP ON LINES
  17904. C
  17905.       DONE = .FALSE.
  17906.    70 CONTINUE
  17907.       IF(DONE) GO TO 50
  17908.       DONE = .TRUE.
  17909.       CALL FILCH(LINE,1,MCPL,BLANK)
  17910. C
  17911. C     LOOP ON ATTRIBUTES
  17912. C
  17913.       DO 100 I=1,NUMATT
  17914.       JP = IP + FP(I) - 1
  17915.       IF(VAR(I)) JP = BUFFER(JP) + IP + 1
  17916.       CALL SELOUT(BUFFER(JP),I,ADONE)
  17917.       DONE = DONE.AND.ADONE
  17918.   100 CONTINUE
  17919.       IF(NLINE.LT.LPP) GO TO 120
  17920.       IF(.NOT.(CONNI.AND.CONNO)) GO TO 108
  17921.       WRITE(NOUTR,104)
  17922.   104 FORMAT(/,28H MORE TEXT FOLLOWS - ENTER * ,
  17923.      X         28H TO CONTINUE OR QUIT TO STOP )
  17924.       PROM = IBLANK
  17925.       CALL LXLREC(IDUM,0,IDUM)
  17926.       PROM = K4RP
  17927.       IF(LXWREC(1,1).EQ.K4QUIT) GO TO 9999
  17928.   108 CONTINUE
  17929.       NLINE = 3
  17930.       IF(.NOT.CONNO) WRITE (NOUTR,110)
  17931.   110 FORMAT(1H1)
  17932.       WRITE (NOUTR,30)
  17933.       CALL SPOUT(TITLE,MCPL)
  17934.       CALL SPOUT(MINUS,MCPL)
  17935.   120 CONTINUE
  17936.       CALL SPOUT(LINE,MCPL)
  17937.       IF(BLNKFL) NLINE = NLINE + 1
  17938.       GO TO 70
  17939.   900 CONTINUE
  17940. C
  17941. C     NO VALID ATTRIBUTES
  17942. C
  17943. C     WRITE (NOUT,910)
  17944. C 910 FORMAT(40H -WARNING- NO VALID ATTRIBUTES SPECIFIED )
  17945.  9999 CONTINUE
  17946.       RETURN
  17947.       END
  17948.       SUBROUTINE SELOUT(MAT,IATT,ADONE)
  17949.         Include TEXT.BLK
  17950. C
  17951. C     THIS ROUTINE STUFFS THE CHARACTER REPRESENTATION OF AN
  17952. C     ATTRIBUTE VALUE INTO LINE FOR LATER PRINTING.
  17953. C
  17954. C     MAT.......DATA FOR THIS ATTRIBUTE
  17955. C     IATT......ATTRIBUTE NUMBER IN SELCOM
  17956. C     ADONE.....SET TO .TRUE. IF NO PARAGRAPHING LEFT
  17957. C
  17958.         Include RMATTS.BLK
  17959.         Include SELCOM.BLK
  17960.         Include MISC.BLK
  17961.       DIMENSION MAT(1)
  17962.       LOGICAL ADONE
  17963.       ADONE = .TRUE.
  17964.       IPOS = 1
  17965.       IF((CURPOS(IATT).NE.1).AND.(PGRAPH(IATT).EQ.0)) GO TO 9999
  17966.       IF(CURPOS(IATT).GT.LEN(IATT)) GO TO 9999
  17967.       IF(ATYPE(IATT).NE.KZTEXT) GO TO 100
  17968. C
  17969. C     TEXT
  17970. C
  17971.       IF(PGRAPH(IATT).NE.0) GO TO 50
  17972. C
  17973. C     NON-PARAGRAPHED TEXT
  17974. C
  17975.       NC = NUMCOL(IATT)
  17976.       IF(NC.GT.LEN(IATT)) NC = LEN(IATT)
  17977.       GO TO 70
  17978.    50 CONTINUE
  17979. C
  17980. C     PARAGRAPHED TEXT
  17981. C
  17982.       NC = NUMCOL(IATT)
  17983.       MAX = LEN(IATT) - CURPOS(IATT) + 1
  17984.       IF(NC.GT.MAX) NC = MAX
  17985.       IF(NC.EQ.MAX) GO TO 70
  17986. C
  17987. C     SEE IF WE NEED WORRY ABOUT BROKEN WORDS
  17988. C
  17989.       MC = 0
  17990.       M2 = ISCAN(MAT(1),CURPOS(IATT)+NC,-NC,IBLANK,1,1,IPOS)
  17991.       IF(IPOS.NE.0) MC = IPOS - CURPOS(IATT) + 1
  17992.       IF(MC.GT.4) NC = MC
  17993.       ADONE = .FALSE.
  17994. C
  17995. C     CHECK IF REMAINDER OF LINE IS BLANK
  17996. C
  17997.       N = LEN(IATT) - CURPOS(IATT) - NC
  17998.       IPOS = NSCAN(MAT(1),CURPOS(IATT)+NC,N,IBLANK,1,1)
  17999.       IF(IPOS.EQ.0) ADONE = .TRUE.
  18000.    70 CONTINUE
  18001.       CALL STRMOV(MAT(1),CURPOS(IATT),NC,LINE,COL1(IATT))
  18002.       CURPOS(IATT) = CURPOS(IATT) + NC
  18003.       IF(IPOS.EQ.0) CURPOS(IATT) = LEN(IATT) + 1
  18004.       GO TO 9999
  18005.   100 CONTINUE
  18006. C
  18007. C     NON-TEXT STUFF
  18008. C
  18009.       IF(ATYPE(IATT).EQ.KZIMAT) GO TO 1000
  18010.       IF(ATYPE(IATT).EQ.KZRMAT) GO TO 1000
  18011.       IF(ATYPE(IATT).EQ.KZDMAT) GO TO 1000
  18012.       IF(SINGLE(IATT).NE.0) GO TO 3000
  18013. C
  18014. C     WE HAVE NON-MATRIX STUFF
  18015. C
  18016.       NUMTOP = (NUMCOL(IATT)+2)/(ITEMW(IATT)+2)
  18017.       IF((PGRAPH(IATT).NE.0).AND.(PGRAPH(IATT).LT.NUMTOP))
  18018.      X             NUMTOP = PGRAPH(IATT)
  18019.       IP = CURPOS(IATT)
  18020.       IF(ATYPE(IATT).EQ.KZDOUB) IP = 2*IP - 1
  18021.       IF(ATYPE(IATT).EQ.KZDVEC) IP = 2*IP - 1
  18022.       IC = COL1(IATT)
  18023.       IF(.NOT.VAR(IATT)) GO TO 150
  18024.       IF(NUMCOL(IATT).LT.20) GO TO 150
  18025.       IF(ATYPE(IATT).EQ.KZIVEC) GO TO 120
  18026.       IF(ATYPE(IATT).EQ.KZRVEC) GO TO 120
  18027.       IF(ATYPE(IATT).EQ.KZDVEC) GO TO 120
  18028.       GO TO 150
  18029.   120 CONTINUE
  18030. C
  18031. C     PUT IN DIMENSION
  18032. C
  18033.       NUMTOP = NUMTOP - 1
  18034.       IF(CURPOS(IATT).EQ.1) CALL ITOC(LINE,IC,6,LEN(IATT),IERR)
  18035.       IC = IC + 10
  18036.   150 CONTINUE
  18037.       NUMT = LEN(IATT) - CURPOS(IATT) + 1
  18038.       IF(NUMTOP.GT.NUMT) NUMTOP = NUMT
  18039.       DO 200 I=1,NUMTOP
  18040.       CALL SELPUT(MAT(IP),ATYPE(IATT),ITEMW(IATT),IC,LINE)
  18041.       IP = IP + 1
  18042.       IF(ATYPE(IATT).EQ.KZDOUB) IP = IP + 1
  18043.       IF(ATYPE(IATT).EQ.KZDVEC) IP = IP + 1
  18044.       IC = IC + 2 + ITEMW(IATT)
  18045.   200 CONTINUE
  18046.       CURPOS(IATT) = CURPOS(IATT) + NUMTOP
  18047.       IF(PGRAPH(IATT).EQ.0) GO TO 9999
  18048.       IF(CURPOS(IATT).LE.LEN(IATT)) ADONE = .FALSE.
  18049.       GO TO 9999
  18050.  1000 CONTINUE
  18051. C
  18052. C     MATRICIES
  18053. C
  18054.       IF(SINGLE(IATT).NE.0) GO TO 3500
  18055.       NUMTOP = (NUMCOL(IATT)+2)/(ITEMW(IATT)+2)
  18056.       IF((PGRAPH(IATT).NE.0).AND.(PGRAPH(IATT).LT.NUMTOP))
  18057.      X             NUMTOP = PGRAPH(IATT)
  18058.       IP = CURPOS(IATT)
  18059.       JC = (IP-1)/ROWD(IATT)
  18060.       JR = IP - JC*ROWD(IATT)
  18061.       JC = JC + 1
  18062.       IC = COL1(IATT)
  18063.       IF(.NOT.VAR(IATT)) GO TO 1150
  18064.       IF(NUMCOL(IATT).LT.20) GO TO 1150
  18065. C
  18066. C     PUT IN ROW AND COLUMN
  18067. C
  18068.       NUMTOP = NUMTOP - 1
  18069.       IF(CURPOS(IATT).NE.1) GO TO 1125
  18070.       CALL ITOC(LINE,IC,4,ROWD(IATT),IERR)
  18071.       CALL ITOC(LINE,IC+4,4,COLD(IATT),IERR)
  18072.  1125 CONTINUE
  18073.       IC = IC + 10
  18074.  1150 CONTINUE
  18075.       NUMT = COLD(IATT)*(ROWD(IATT)-JR) + COLD(IATT) - JC + 1
  18076.       IF(NUMTOP.GT.NUMT) NUMTOP = NUMT
  18077.       DO 1200 I=1,NUMTOP
  18078.       IP = ROWD(IATT)*(JC-1) + JR
  18079.       IF(ATYPE(IATT).EQ.KZDMAT) IP = 2 * IP - 1
  18080.       CALL SELPUT(MAT(IP),ATYPE(IATT),ITEMW(IATT),IC,LINE)
  18081.       JC = JC + 1
  18082.       IF(JC.LE.COLD(IATT)) GO TO 1170
  18083.       JC = 1
  18084.       JR = JR + 1
  18085.       IF(PGRAPH(IATT).NE.0) GO TO 1220
  18086.  1170 CONTINUE
  18087.       IC = IC + 2 + ITEMW(IATT)
  18088.  1200 CONTINUE
  18089.  1220 CONTINUE
  18090.       IF(.NOT.TRUNC(IATT)) GO TO 1240
  18091.       IF(JC.EQ.1) GO TO 1240
  18092.       JR = JR + 1
  18093.       JC = 1
  18094.  1240 CONTINUE
  18095.       CURPOS(IATT) = ROWD(IATT)*(JC-1) + JR
  18096.       IF(PGRAPH(IATT).EQ.0) GO TO 9999
  18097.       IF(JR.LE.ROWD(IATT)) ADONE = .FALSE.
  18098.       IF(ADONE)CURPOS(IATT) = LEN(IATT) + 1
  18099.       GO TO 9999
  18100.  3000 CONTINUE
  18101. C
  18102. C     SINGLE ITEM FROM A VECTOR
  18103. C
  18104.       IP = SINGLE(IATT)
  18105.       CURPOS(IATT) = LEN(IATT) + 1
  18106.       IF(IP.GT.LEN(IATT)) GO TO 3800
  18107.       CALL SELPUT(MAT(IP),ATYPE(IATT),ITEMW(IATT),COL1(IATT),LINE)
  18108.       GO TO 9999
  18109.  3500 CONTINUE
  18110. C
  18111. C     SINGLE ITEM FROM A MATRIX
  18112. C
  18113.       CURPOS(IATT) = LEN(IATT) + 1
  18114.       CALL ITOH(JR,JC,SINGLE(IATT))
  18115.       IF(JR.GT.ROWD(IATT)) GO TO 3800
  18116.       IF(JC.GT.COLD(IATT)) GO TO 3800
  18117.       IP = ROWD(IATT)*(JC-1) + JR
  18118.       IF(ATYPE(IATT).EQ.KZDMAT) IP = 2 * IP - 1
  18119.       CALL SELPUT(MAT(IP),ATYPE(IATT),ITEMW(IATT),COL1(IATT),LINE)
  18120.       GO TO 9999
  18121.  3800 CONTINUE
  18122. C
  18123. C     OUT OF RANGE
  18124. C
  18125.       CALL SELPUT(NULL,ATYPE(IATT),ITEMW(IATT),COL1(IATT),LINE)
  18126.  9999 CONTINUE
  18127.       RETURN
  18128.       END
  18129.       SUBROUTINE SELPAR(ITALLY)
  18130.         Include TEXT.BLK
  18131. C
  18132. C     THIS ROUTINE GOES THRU ATTRIBUTES SPECIFIED ON THE SELECT
  18133. C     COMMAND THEN (OR ALL) AND
  18134. C     1. BUILDS THE TITLE LINE
  18135. C     2.BUILDS THE MINUS LINE
  18136. C     3.SET INFORMATION INTO COMMON BLOCK SELCOM
  18137. C
  18138.         Include RMATTS.BLK
  18139.         Include RMKEYW.BLK
  18140.         Include CONST8.BLK
  18141.         Include CONST4.BLK
  18142.         Include MISC.BLK
  18143.         Include TUPLEA.BLK
  18144.         Include TUPLER.BLK
  18145.         Include FILES.BLK
  18146.         Include SELCOM.BLK
  18147.       LOGICAL EQKEYW,END,IFALL
  18148.       LOGICAL ITALLY
  18149.       INTEGER STATUS
  18150.         Include DCLAR1.BLK
  18151. C
  18152. C     INITIALIZE
  18153. C
  18154.       NUMBAD = 0
  18155.       NUM = CHPWD*(1+((MCPL-1)/CHPWD))
  18156.       CALL FILCH(TITLE,1,NUM,BLANK)
  18157.       CALL FILCH(MINUS,1,NUM,BLANK)
  18158.       CALL FILCH(LINE,1,NUM,BLANK)
  18159.       NUMATT = 0
  18160.       IT = 2
  18161.       ITEMS = LXITEM(DUM)
  18162.       LAST = LFIND(1,ITEMS,KWFROM,4)
  18163.       LAST = LAST - 1
  18164.       IF(ITALLY) LAST = 2
  18165.       IFALL = .FALSE.
  18166.       IP = 0
  18167.       IF(LAST.NE.2) GO TO 10
  18168.       IF(.NOT.EQKEYW(IT,KWALL,3)) GO TO 10
  18169. C
  18170. C     ALL
  18171. C
  18172.       IFALL = .TRUE.
  18173.       CALL LOCATT(BLANK,NAME)
  18174. C
  18175. C     LOOP ON ATTRIBUTES
  18176. C
  18177.    10 CONTINUE
  18178. C
  18179. C     GET ATTRIBUTE INTO TUPLEA
  18180. C
  18181.       IF(IFALL) GO TO 50
  18182. C
  18183. C     LOOK AT NEXT ATTRIBUTE
  18184. C
  18185.       IF(IT.GT.LAST) GO TO 1000
  18186.       IF(LXID(IT).NE.KZINT) GO TO 15
  18187. C
  18188. C     INTEGER ATTRIBUTE NUMBER
  18189. C
  18190.       NUM = LXIREC(IT)
  18191.       IT = IT + 1
  18192.       IF(NUM.LE.0) GO TO 880
  18193.       IF(NUM.GT.NATT) GO TO 880
  18194.       CALL LOCATT(BLANK,NAME)
  18195.       DO 12 I=1,NUM
  18196.       CALL ATTGET(STATUS)
  18197.       IF(STATUS.NE.0) GO TO 880
  18198.    12 CONTINUE
  18199.       GO TO 20
  18200.    15 CONTINUE
  18201.       ANAME = BLANK
  18202.       CALL LXSREC(IT,1,8,ANAME,1)
  18203.       IT = IT + 1
  18204.       CALL LOCATT(ANAME,NAME)
  18205.       CALL ATTGET(STATUS)
  18206.       IF(STATUS.EQ.0) GO TO 20
  18207.       CALL WARN(3,ANAME,NAME)
  18208.       NUMBAD = NUMBAD + 1
  18209.       GO TO 10
  18210.    20 CONTINUE
  18211.       NUMATT = NUMATT + 1
  18212.       IF(NUMATT.GT.20) GO TO 8040
  18213. C
  18214. C     SEE IF MAT(I,J) OR VEC(I,J)
  18215. C
  18216.       SINGLE(NUMATT) = 0
  18217.       IF(LXID(IT).NE.KZTEXT) GO TO 40
  18218.       IF(LXLENC(IT).NE.1) GO TO 40
  18219.       IF(LXWREC(IT,1).NE.K4LPAR) GO TO 40
  18220.       NUM = 0
  18221.       IF(ATTYPE.EQ.KZIVEC) NUM = 1
  18222.       IF(ATTYPE.EQ.KZRVEC) NUM = 1
  18223.       IF(ATTYPE.EQ.KZDVEC) NUM = 1
  18224.       IF(ATTYPE.EQ.KZIMAT) NUM = 2
  18225.       IF(ATTYPE.EQ.KZRMAT) NUM = 2
  18226.       IF(ATTYPE.EQ.KZDMAT) NUM = 2
  18227.       NUMA = 0
  18228.       IF(LXWREC(IT+2,1).EQ.K4RPAR) NUMA = 1
  18229.       IF(LXWREC(IT+3,1).EQ.K4RPAR) NUMA = 2
  18230.       IF(NUM.EQ.0) GO TO 800
  18231.       IF(NUMA.EQ.0) GO TO 820
  18232.       IF(NUM.NE.NUMA) GO TO 840
  18233.       IF(LXID(IT+1).NE.KZINT) GO TO 860
  18234.       IF(LXID(IT+NUMA).NE.KZINT) GO TO 860
  18235.       I1 = LXIREC(IT+1)
  18236.       I2 = 1
  18237.       IF(NUM.EQ.2) I2 = LXIREC(IT+2)
  18238.       IF(I1.LE.0) GO TO 860
  18239.       IF(I2.LE.0) GO TO 860
  18240.       CALL ITOH(N1,N2,ATTLEN)
  18241.       IF(N2.EQ.0) GO TO 30
  18242.       IF(ATTYPE.EQ.KZDVEC) N2 = N2/2
  18243.       IF(ATTYPE.EQ.KZDMAT) N2 = N2/2
  18244.       IF(NUM.EQ.1) GO TO 25
  18245.       IF(N1.NE.0) N2 = N2/N1
  18246.       IF(I1.GT.N1) GO TO 8020
  18247.       IF(I2.GT.N2) GO TO 8020
  18248.       GO TO 30
  18249.    25 CONTINUE
  18250.       IF(I1.GT.N2) GO TO 8020
  18251.    30 CONTINUE
  18252.       SINGLE(NUMATT) = I1
  18253.       IF(NUM.EQ.2)CALL HTOI(I1,I2,SINGLE(NUMATT))
  18254.       IT = IT + 2 + NUMA
  18255.    40 CONTINUE
  18256. C
  18257. C     SEE IF NEXT IS PARAGRAPH
  18258. C
  18259.       PGRAPH(NUMATT) = 0
  18260.       IF(IT.GT.LAST) GO TO 100
  18261.       IF(LXWREC(IT,1).NE.K4EQS) GO TO 100
  18262.       IF(LXID(IT+1).NE.KZINT) GO TO 8000
  18263.       PGRAPH(NUMATT) = LXIREC(IT+1)
  18264.       IT = IT + 2
  18265.       GO TO 100
  18266.    50 CONTINUE
  18267. C
  18268. C     ALL
  18269. C
  18270.       CALL ATTGET(STATUS)
  18271.       IF(STATUS.NE.0) GO TO 1000
  18272.       NUMATT = NUMATT + 1
  18273.       IF(NUMATT.GT.20) GO TO 8040
  18274.       PGRAPH(NUMATT) = 0
  18275.       SINGLE(NUMATT) = 0
  18276.   100 CONTINUE
  18277. C
  18278. C     GOT ATTRIBUTE IN TUPLEA
  18279. C
  18280.       NC = 0
  18281.       IF(IP.GT.(MCPL-10)) NUMATT = NUMATT - 1
  18282.       IF(IP.GT.(MCPL-10)) GO TO 900
  18283.       IP = IP + 2
  18284.       ICOL = ATTCHA
  18285.       NWORDS = ATTWDS
  18286.       IF(ATTYPE.EQ.KZDOUB) NWORDS = NWORDS/2
  18287.       IF(ATTYPE.EQ.KZDVEC) NWORDS = NWORDS/2
  18288.       IF(ATTYPE.EQ.KZDMAT) NWORDS = NWORDS/2
  18289.       COL1(NUMATT) = IP
  18290.       ATYPE(NUMATT) = ATTYPE
  18291.       LEN(NUMATT) = NWORDS
  18292.       IF(ATTYPE.EQ.KZTEXT)LEN(NUMATT) = ICOL
  18293.       ROWD(NUMATT) = ICOL
  18294.       COLD(NUMATT) = 0
  18295.       IF(ICOL.NE.0) COLD(NUMATT) = NWORDS/ICOL
  18296.       VAR(NUMATT) = NWORDS.EQ.0
  18297.       FP(NUMATT) = ATTCOL
  18298.       IF(VAR(NUMATT)) GO TO 200
  18299. C
  18300. C     FIXED STUFF
  18301. C
  18302.       TRUNC(NUMATT) = .FALSE.
  18303.       GO TO 300
  18304.   200 CONTINUE
  18305. C
  18306. C     VARIABLE STUFF
  18307. C
  18308.       TRUNC(NUMATT) = .FALSE.
  18309.       IF(PGRAPH(NUMATT).NE.0) GO TO 300
  18310.       PGRAPH(NUMATT) = 4
  18311.       IF(ATTYPE.EQ.KZTEXT) PGRAPH(NUMATT) = 40
  18312.   300 CONTINUE
  18313.       ITEMW(NUMATT) = 8
  18314.       IF(ATTYPE.EQ.KZTEXT)ITEMW(NUMATT) = 1
  18315.       NC = LEN(NUMATT) * (2 + ITEMW(NUMATT)) - 2
  18316.       IF(PGRAPH(NUMATT).NE.0)NC = PGRAPH(NUMATT)*(2+ITEMW(NUMATT))-2
  18317.       IF(ATTYPE.NE.KZTEXT) GO TO 310
  18318.       NC = LEN(NUMATT)
  18319.       IF(PGRAPH(NUMATT).NE.0) NC = PGRAPH(NUMATT)
  18320.   310 CONTINUE
  18321.       IF(SINGLE(NUMATT).NE.0) NC = ITEMW(NUMATT) + 2
  18322.       IF(NC.LE.0) NC = 40
  18323. C
  18324. C     INSERT TITLE
  18325. C
  18326.       JP = IP
  18327.       IF(.NOT.VAR(NUMATT)) GO TO 315
  18328.       IF(NC.LT.20) GO TO 315
  18329.       IF(ATTYPE.EQ.KZTEXT) GO TO 315
  18330.       IF(ATTYPE.EQ.KZINT) GO TO 315
  18331.       IF(ATTYPE.EQ.KZREAL) GO TO 315
  18332.       IF(ATTYPE.EQ.KZDOUB) GO TO 315
  18333.       IF(ATTYPE.EQ.KZIVEC) CALL STRMOV(K4DIM,1,3,TITLE,IP+3)
  18334.       IF(ATTYPE.EQ.KZRVEC) CALL STRMOV(K4DIM,1,3,TITLE,IP+5)
  18335.       IF(ATTYPE.EQ.KZDVEC) CALL STRMOV(K4DIM,1,3,TITLE,IP+5)
  18336.       IF(ATTYPE.EQ.KZRMAT) CALL STRMOV(K8RC,1,8,TITLE,IP)
  18337.       IF(ATTYPE.EQ.KZDMAT) CALL STRMOV(K8RC,1,8,TITLE,IP)
  18338.       IF(ATTYPE.EQ.KZIMAT) CALL STRMOV(K8RC,1,8,TITLE,IP)
  18339.       JP = IP + 10
  18340.   315 CONTINUE
  18341.       CALL STRMOV(ATTNAM,1,MIN0(8,NC),TITLE,JP)
  18342.       END = .FALSE.
  18343.       IF((IP+NC-1).GT.MCPL) END = .TRUE.
  18344.       IF(END) NC = MCPL - IP + 1
  18345.       NUMCOL(NUMATT) = NC
  18346. C
  18347. C     MAKE DASHES
  18348. C
  18349.       CALL FILCH(MINUS,IP,NC,K4MNUS)
  18350.       IP = IP + NC
  18351.       IF(.NOT.END) GO TO 10
  18352.       GO TO 900
  18353.   800 CONTINUE
  18354. C
  18355. C     WRONG TYPE FOR FOLLOWING PARENS
  18356. C
  18357.       WRITE (NOUT,810)
  18358.   810 FORMAT(58H -ERROR- ATTRIBUTE MUST BE VEC OR MAT FOR FOLLOWING PARE
  18359.      XNS)
  18360.       GO TO 9000
  18361.   820 CONTINUE
  18362. C
  18363. C     TRAILING PAREN IMPROPERLY SPECIFIED
  18364. C
  18365.       WRITE (NOUT,830)
  18366.   830 FORMAT(36H -ERROR- COULDN'T FIND CLOSING PAREN)
  18367.       GO TO 9000
  18368.   840 CONTINUE
  18369. C
  18370. C     VEC/MAT MISMATCH
  18371. C
  18372.       WRITE (NOUT,850)
  18373.   850 FORMAT(38H -ERROR- NUMBER OF DIMENSIONS MISMATCH)
  18374.       GO TO 9000
  18375.   860 CONTINUE
  18376. C
  18377. C     ROW/COL MUST BE POSITIVE INTEGER
  18378. C
  18379.       WRITE (NOUT,870)
  18380.   870 FORMAT(42H -ERROR- ROW/COL MUST BE POSITIVE INTEGERS)
  18381.       GO TO 9000
  18382.   880 CONTINUE
  18383. C
  18384. C     BAD INTEGER ATTRIBUTE
  18385. C
  18386.       WRITE (NOUT,890)
  18387.   890 FORMAT(49H -ERROR- IMPROPER INTEGER ATTRIBUTE SPECIFICATION )
  18388.       GO TO 9000
  18389.   900 CONTINUE
  18390. C
  18391. C     OOPS - NOT ENOUGH ROOM
  18392. C
  18393.       WRITE(NOUT,910)
  18394.   910 FORMAT(25H -WARNING- LINE TRUNCATED )
  18395.  1000 CONTINUE
  18396.       MCPL = IP - 1
  18397.       IF(NUMBAD.GT.0) GO TO 9000
  18398.       RETURN
  18399.  8000 CONTINUE
  18400. C
  18401. C     PARAGRAPH NOT INTEGER
  18402. C
  18403.       WRITE (NOUT,8010)
  18404.  8010 FORMAT(41H -ERROR- IMPROPER PARAGRAPH SPECIFICATION )
  18405.       GO TO 9000
  18406.  8020 CONTINUE
  18407. C
  18408. C     SINGLE TOO BIG
  18409. C
  18410.       WRITE (NOUT,8030)
  18411.  8030 FORMAT(39H -ERROR- REQUESTED ELEMENT OUT OF RANGE )
  18412.       GO TO 9000
  18413.  8040 CONTINUE
  18414. C
  18415. C  TOO MAY ATTRIBUTES SPECIFIED
  18416. C
  18417.       WRITE(NOUT,8050)
  18418.  8050 FORMAT(46H -ERROR- ILLEGAL NUMBER OF ATTRIBUTES (MAX 20))
  18419.       GO TO 9000
  18420.  9000 CONTINUE
  18421. C
  18422. C     BLEW IT
  18423. C
  18424.       NUMATT = 0
  18425.       CALL WARN(4,0,0)
  18426.       RETURN
  18427.       END
  18428.       SUBROUTINE SELPUT(VAL,TYPE,WIDTH,START,STRING)
  18429.         Include TEXT.BLK
  18430. C
  18431. C     THIS ROUTINE PUTS AN ACTUAL VALUE (NON-TEXT) INTO STRING.
  18432. C
  18433.         Include RMATTS.BLK
  18434.         Include CONST4.BLK
  18435.         Include MISC.BLK
  18436. C
  18437.       INTEGER VAL,TYPE,WIDTH,START,STRING(1)
  18438.       IF(VAL.EQ.IBLANK) RETURN
  18439.       IF(VAL.NE.NULL) GO TO 100
  18440. C
  18441. C     NULL
  18442. C
  18443.       N = 3
  18444.       IF(WIDTH.LT.N) N = WIDTH
  18445.       CALL STRMOV(NULL,1,N,STRING,START)
  18446.       GO TO 9999
  18447.   100 CONTINUE
  18448.       IF(TYPE.EQ.KZINT) GO TO 200
  18449.       IF(TYPE.EQ.KZIVEC) GO TO 200
  18450.       IF(TYPE.EQ.KZIMAT) GO TO 200
  18451. C
  18452. C     TREAT AS REAL
  18453. C
  18454.       CALL RTOC(STRING,START,WIDTH,VAL)
  18455.       GO TO 9999
  18456.   200 CONTINUE
  18457. C
  18458. C     INTEGER
  18459. C
  18460.       CALL ITOC(STRING,START,WIDTH,VAL,IERR)
  18461.       IF(IERR.EQ.0) GO TO 9999
  18462.       CALL FILCH(STRING,START,WIDTH,K4STAR)
  18463.  9999 CONTINUE
  18464.       RETURN
  18465.       END
  18466.       SUBROUTINE SETIN(HFILE)
  18467.         Include TEXT.BLK
  18468. C
  18469. C     SET THE INPUT FILE TO IFILE
  18470. C
  18471.         Include CONST4.BLK
  18472.         Include CONST8.BLK
  18473.         Include FILES.BLK
  18474.       LOGICAL EQ,ISITIN
  18475.       REAL*8 HFILE
  18476.       CHARACTER*8 IFILE
  18477.       WRITE(IFILE,10) HFILE
  18478.    10 FORMAT(A8)
  18479.       IF(NINT.EQ.10) CLOSE(NINT)
  18480.       IF(EQ(HFILE,K8IN)) GO TO 100
  18481. C
  18482. C     NOT INPUT FILE
  18483. C
  18484.       CONNI = .FALSE.
  18485.       NINT = 10
  18486.     INQUIRE(FILE=IFILE,EXIST=ISITIN)
  18487.     IF(ISITIN)GOTO 50
  18488.     OPEN(UNIT=NINT,FILE=IFILE,STATUS='NEW')
  18489.     GOTO 51
  18490. 50    CONTINUE
  18491.     OPEN(UNIT=NINT,FILE=IFILE,STATUS='OLD')
  18492. 51    CONTINUE
  18493.       GO TO 900
  18494.   100 CONTINUE
  18495. C
  18496. C     INPUT FILE - NEVER CLOSED
  18497. C
  18498. C
  18499. C  CHECK THAT INPUT IS INPUT
  18500. C
  18501.       CONNI = .TRUE.
  18502. C **** System Dependent ****
  18503.       NINT = 9
  18504.     Rewind 9
  18505.   900 CONTINUE
  18506.       CALL LXSET(K4INPT,NINT)
  18507.       RETURN
  18508.       END
  18509.       SUBROUTINE SETOUT(HFILE)
  18510.         Include TEXT.BLK
  18511. C
  18512. C     SET THE OUTPUT FILE TO IFILE
  18513. C
  18514.         Include CONST4.BLK
  18515.         Include CONST8.BLK
  18516.         Include FILES.BLK
  18517.       LOGICAL EQ,ISITIN
  18518.       REAL*8 HFILE
  18519.       CHARACTER*8 IFILE
  18520.       WRITE(IFILE,10) HFILE
  18521.    10 FORMAT(A8)
  18522.       IF(NOUT.EQ.11) CLOSE(NOUT)
  18523.       IF(NOUTR.EQ.11) CLOSE(NOUTR)
  18524.       IF(EQ(HFILE,K8OUT)) GO TO 100
  18525. C
  18526. C     NOT OUTPUT FILE
  18527. C
  18528.       CONNO = .FALSE.
  18529.       NOUTR = 11
  18530. C MSDOS MS FORTRAN DOESN'T HAVE 'UNKNOWN' STATUS ABILITY
  18531. C SO EXPLICITLY SEE IF THE FILE EXISTS AND OPEN IT
  18532. C AS NEW IF NOT, AND AS OLD IF IT DOES EXIST.
  18533. C GCE 7/85
  18534.     INQUIRE(FILE=IFILE,EXIST=ISITIN)
  18535.     IF(ISITIN)GOTO 50
  18536.     OPEN(UNIT=NOUTR,FILE=IFILE,STATUS='NEW')
  18537.     GOTO 51
  18538. 50    CONTINUE
  18539.       OPEN(UNIT=NOUTR,FILE=IFILE,STATUS='OLD')
  18540. 51    CONTINUE
  18541.       NOUT = 11
  18542. C **** System Dependent ****
  18543.       IF(CONNI) NOUT = 9
  18544.     IF(CONNI) rewind 9
  18545.       GO TO 900
  18546.   100 CONTINUE
  18547. C
  18548. C     OUTPUT FILE - NEVER CLOSED
  18549. C
  18550. C
  18551. C  CHECK THAT OUTPUT IS OUTPUT
  18552. C
  18553.       CONNO = .TRUE.
  18554. C **** System Dependent ****
  18555.       NOUT = 9
  18556.       NOUTR = 9
  18557.     Rewind 9
  18558.   900 CONTINUE
  18559.       CALL LXSET(K4OTPT,NOUTR)
  18560.       RETURN
  18561.       END
  18562.       SUBROUTINE SETRUL
  18563.         Include TEXT.BLK
  18564. C
  18565. C  THIS ROUTINE SETS UP THE RELATIONS NECESSARY TO ALLOW THE USER
  18566. C  TO DEFINE RULES FOR PROCESSING A RIM SCHEMA.  THESE RELATIONS
  18567. C  ARE :
  18568. C
  18569. C         RIMRDT --- THE RIM SCHEMA COMPILER RULE DESCRIPTION TABLE.
  18570. C
  18571. C         RIMRRC  --- THE RIM SCHEMA COMPILER RULE RELATION
  18572. C                     CORRESPONDENCE TABLE.
  18573. C
  18574.         Include RMATTS.BLK
  18575.         Include CONST4.BLK
  18576.         Include CONST8.BLK
  18577.         Include TUPLER.BLK
  18578.         Include TUPLEA.BLK
  18579.         Include MISC.BLK
  18580. C
  18581. C
  18582. C  SET UP RELATION TABLE FOR RIMRRC.
  18583. C
  18584.       NAME = K8RRC
  18585.       CALL RMDATE(RDATE)
  18586.       NCOL = 3
  18587.       NATT = 2
  18588.       NTUPLE = 0
  18589.       RSTART = 0
  18590.       REND = 0
  18591.       RPW = K8DBA
  18592.       MPW = K8DBA
  18593.       CALL RELADD
  18594.       CALL ATTNEW(NAME,2)
  18595. C
  18596. C  ADD ATTRIBUTES FOR RIMRRC
  18597. C
  18598.       RELNAM = NAME
  18599.       ATTKEY = 0
  18600.       NW = (8-1)/CHPWD + 1
  18601. C
  18602. C  RELATION NAME
  18603. C
  18604.       ATTNAM = K8NAM
  18605.       ATTCOL = 1
  18606.       CALL HTOI(8,NW,ATTLEN)
  18607.       ATTYPE = KZTEXT
  18608.       CALL ATTADD
  18609. C
  18610. C  RULE NUMBER
  18611. C
  18612.       ATTNAM = K8NUM
  18613.       ATTCOL = 3
  18614.       ATTLEN = 1
  18615.       ATTYPE = KZINT
  18616.       CALL ATTADD
  18617. C
  18618. C  SET UP RIMRDT RELATION
  18619. C
  18620.       NAME = K8RDT
  18621.       CALL RMDATE(RDATE)
  18622.       NCOL = 14 + ((40-1)/CHPWD + 1)
  18623.       NATT = 9
  18624.       NTUPLE = 0
  18625.       RSTART = 0
  18626.       REND = 0
  18627.       RPW = K8DBA
  18628.       MPW = K8DBA
  18629.       CALL RELADD
  18630.       CALL ATTNEW(NAME,9)
  18631. C
  18632. C  ADD ATTRIBUTES FOR RIMRDT
  18633. C
  18634.       ATTKEY = 0
  18635.       RELNAM = NAME
  18636. C
  18637. C  RULE NUMBER
  18638. C
  18639.       ATTNAM = K8NUM
  18640.       ATTCOL = 1
  18641.       ATTLEN = 1
  18642.       ATTYPE = KZINT
  18643.       CALL ATTADD
  18644. C
  18645. C  AND/OR SWITCH
  18646. C
  18647.       ATTNAM = K8AOR
  18648.       ATTCOL = 2
  18649.       CALL HTOI(8,NW,ATTLEN)
  18650.       ATTYPE = KZTEXT
  18651.       CALL ATTADD
  18652. C
  18653. C  1ST ATTRIBUTE NAME
  18654. C
  18655.       ATTNAM = K8AN1
  18656.       ATTCOL = 4
  18657.       CALL HTOI(8,NW,ATTLEN)
  18658.       ATTYPE = KZTEXT
  18659.       CALL ATTADD
  18660. C
  18661. C  RELATION OR BLANK
  18662. C
  18663.       ATTNAM = K8RN1
  18664.       ATTCOL = 6
  18665.       CALL HTOI(8,NW,ATTLEN)
  18666.       ATTYPE = KZTEXT
  18667.       CALL ATTADD
  18668. C
  18669. C  BOOLEAN OPERATOR
  18670. C
  18671.       ATTNAM = K8OPR
  18672.       ATTCOL = 8
  18673.       CALL HTOI(8,NW,ATTLEN)
  18674.       ATTYPE = KZTEXT
  18675.       CALL ATTADD
  18676. C
  18677. C  2ND ITEM DESCRIPTOR
  18678. C
  18679.       ATTNAM = K8TYP
  18680.       ATTCOL = 10
  18681.       ATTLEN = 1
  18682.       ATTYPE = KZINT
  18683.       CALL ATTADD
  18684. C
  18685. C  2ND ATTRIBUTE NAME
  18686. C
  18687.       ATTNAM = K8AN2
  18688.       ATTCOL = 11
  18689.       CALL HTOI(8,NW,ATTLEN)
  18690.       ATTYPE = KZTEXT
  18691.       CALL ATTADD
  18692. C
  18693. C  2ND RELATION OR BLANK
  18694. C
  18695.       ATTNAM = K8RN2
  18696.       ATTCOL = 13
  18697.       CALL HTOI(8,NW,ATTLEN)
  18698.       ATTYPE = KZTEXT
  18699.       CALL ATTADD
  18700. C
  18701. C  VALUE.
  18702. C
  18703.       ATTNAM = K8VAL
  18704.       ATTCOL = 15
  18705.       NW = (40-1)/CHPWD + 1
  18706.       CALL HTOI(40,NW,ATTLEN)
  18707.       ATTYPE = KZTEXT
  18708.       CALL ATTADD
  18709. C
  18710. C  DONE WITH SETRULE.
  18711. C
  18712.       RETURN
  18713.       END
  18714.       SUBROUTINE SORT(NKSORT,IOS)
  18715.         Include TEXT.BLK
  18716. C
  18717. C  PURPOSE:  INTERFACE WITH SWCON TO SORT RIM DATA
  18718. C
  18719. C  PARAMETERS:
  18720. C              NKSORT--INDICATOR FOR THE TYPE OF SORT
  18721. C                        1=TUPLE SORT (SELECT)
  18722. C                        2=ATTRIBUTE SORT (TALLY)
  18723. C                        3=ID (POINTER) + ATTRIBUTE SORT (BUILD)
  18724. C              INDPTR--MULTIPLE RMHUNT INDEX - USED TO ASSIGN FILES
  18725. C
  18726. C              IOS--ERROR FLAG FROM OPEN STATEMENT MUST BE 0 OR ELSE..
  18727. C
  18728.         Include RIMPTR.BLK
  18729.         Include WHCOM.BLK
  18730.         Include SRTCOM.BLK
  18731.         Include RIMCOM.BLK
  18732.         Include FILES.BLK
  18733.         Include MISC.BLK
  18734.         Include BUFFER.BLK
  18735.         Include TUPLEA.BLK
  18736.         Include TUPLER.BLK
  18737.         Include INCORE.BLK
  18738. C
  18739.       INTEGER INFIL
  18740.       INTEGER OUTFIL
  18741. C
  18742. C  OPEN THE INPUT SORT FILE
  18743. C
  18744.       INFIL = 20
  18745.       OPEN(INFIL,FILE='SORTFIL.DAT',ACCESS='SEQUENTIAL',
  18746.      &   FORM='UNFORMATTED',STATUS='NEW',IOSTAT=IOS)
  18747.       IF(IOS.EQ.0)GOTO 50
  18748.       NSORT=0
  18749.       GOTO 999
  18750.    50 CONTINUE
  18751. C
  18752. C  SET UP TUPLE LIMITS - SAVE USER SPECIFIED LIMIT
  18753. C
  18754.       LIMTUS = LIMTU
  18755.       LIMTU = ALL9S
  18756. C
  18757. C  BRANCH DEPENDING ON THE TYPE OF SORT REQUESTED
  18758. C
  18759.       IF(NKSORT.EQ.2) GO TO 350
  18760.       IF(NKSORT.EQ.3) GO TO 370
  18761. C
  18762. C  TUPLE SORT - WRITE THE COMPLETE TUPLE ON THE SORT FILE
  18763. C
  18764. C  CHECK FOR VARIABLE LENGTH TUPLES IN THE RELATION
  18765. C
  18766.       FIXLT = .TRUE.
  18767.       I = LOCATT(BLANK,NAME)
  18768.       DO 100 J=1,NATT
  18769.       CALL ATTGET(ISTATX)
  18770.       IF(ISTATX.NE.0) GO TO 110
  18771.       IF(ATTWDS.EQ.0) FIXLT = .FALSE.
  18772.   100 CONTINUE
  18773.   110 CONTINUE
  18774. C
  18775. C  INITIALIZE THE REMAINING VARIABLES
  18776. C
  18777.       LTUMAX = 0
  18778.       LTUMIN = ALL9S
  18779.       NSORT = 0
  18780.       LTUPLE = 0
  18781.       IF(FIXLT) LTUPLE = NCOL
  18782. C
  18783. C  READ IN THE TUPLES AND WRITE THE SORT FILE
  18784. C
  18785.   200 CONTINUE
  18786.       CALL RMLOOK(IP,1,1,LEN)
  18787.       IF(RMSTAT.NE.0) GO TO 400
  18788.       NSORT = NSORT + 1
  18789.       IP = IP - 1
  18790.       IF(FIXLT) GO TO 300
  18791. C
  18792. C  VARIBLE LENGTH TUPLE
  18793. C
  18794.       LTUPLE = LTUPLE + LEN
  18795.       IF(LEN.GT.LTUMAX) LTUMAX = LEN
  18796.       IF(LEN.LT.LTUMIN) LTUMIN = LEN
  18797.       WRITE(INFIL) LEN,(BUFFER(IP+K),K=1,LEN)
  18798.       GO TO 200
  18799. C
  18800. C  FIXED LENGTH TUPLES
  18801. C
  18802.   300 CONTINUE
  18803.       WRITE(INFIL) (BUFFER(IP+K),K=1,LEN)
  18804.       GO TO 200
  18805. C
  18806. C  ATTRIBUTE SORT - WRITE ONLY THE REQUESTED ATTRIBUTE ON THE SORT FILE
  18807. C
  18808.   350 CONTINUE
  18809.       FIXLT = .TRUE.
  18810.       LTUMAX = 0
  18811.       LTUMIN = ALL9S
  18812.       NSORT = 0
  18813.       LTUPLE = ATTWDS
  18814. C
  18815. C  READ THE TUPLES AND WRITE THE ATTRIBUTE VALUES ON THE SORT FILE
  18816. C
  18817.   360 CONTINUE
  18818.       CALL RMLOOK(IP,1,1,LEN)
  18819.       IF(RMSTAT.NE.0) GO TO 400
  18820.       NSORT = NSORT + 1
  18821.       IP = IP - 2
  18822.       WRITE(INFIL) (BUFFER(IP+ATTCOL+K),K=1,LTUPLE)
  18823.       GO TO 360
  18824. C
  18825. C  ID + ATTRIBUTE SORT (BUILD)
  18826. C
  18827.   370 CONTINUE
  18828.       FIXLT = .TRUE.
  18829.       LTUMAX = 0
  18830.       LTUMIN = ALL9S
  18831.       NSORT = 0
  18832.       LTUPLE = 2
  18833.   380 CONTINUE
  18834.       IF(NID.EQ.0) GO TO 400
  18835.       CID = NID
  18836.       CALL GETDAT(1,NID,ITUP,LENGT)
  18837.       IF(NID.LT.0) GO TO 400
  18838.       IP = ITUP + ATTCOL - 1
  18839.       IF(ATTWDS.NE.0) GO TO 390
  18840. C
  18841. C  ATTRIBUTE IS A VARIABLE LENGTH ATTRIBUTE.
  18842. C
  18843.       IP = BUFFER(IP) + ITUP + 1
  18844.   390 CONTINUE
  18845.       IF(BUFFER(IP).EQ.NULL) GO TO 380
  18846. C
  18847. C WRITE THE SORT FILE
  18848. C
  18849.       NSORT = NSORT + 1
  18850.       WRITE(INFIL) BUFFER(IP),CID
  18851.       GO TO 380
  18852. C
  18853. C  CHECK THAT SOME TUPLES WERE WRITTIN ON INFIL
  18854. C  RESET THE TUPLE LIMIT
  18855. C
  18856.   400 CONTINUE
  18857.       LIMTU = LIMTUS
  18858.       IF(NSORT.GT.0) GO TO 420
  18859.       WRITE(NOUT,410)
  18860.   410 FORMAT(36H -WARNING- NO ROWS AVAILABLE TO SORT)
  18861.       GO TO 999
  18862. C
  18863. C  OPEN THE OUTPUT FILES
  18864. C
  18865.   420 CONTINUE
  18866.       OUTFIL = 20
  18867. C
  18868. C  CLEAR OUT ANY PAGE DATA LEFT IN BUFFER
  18869. C
  18870.       CALL BLKCLN
  18871. C
  18872. C  FIXUP THE LENGTHS FOR THE VARIABLE LENGTH STUFF
  18873. C
  18874.       IF(FIXLT) GO TO 440
  18875.       LTUPLE = LTUPLE + NSORT
  18876.       LTUMAX = LTUMAX + 1
  18877.       LTUMIN = LTUMIN + 1
  18878. C
  18879. C  CALL SWCON TO DO THE ACTUAL SORT
  18880. C
  18881.   440 CONTINUE
  18882.       IERR = 0
  18883.       CALL SWCON(BUFFER,LIMIT,INFIL,OUTFIL,IERR)
  18884.       IF(IERR.EQ.0) GO TO 450
  18885.       WRITE(NOUT,445)
  18886.   445 FORMAT(17H -ERROR- SORT I/O)
  18887.       NSORT = 0
  18888.       GO TO 999
  18889. C
  18890.   450 CONTINUE
  18891.       RMSTAT = 0
  18892. C
  18893.   999 CONTINUE
  18894.       RETURN
  18895.       END
  18896.       SUBROUTINE SPOUT(STRING,NUMC)
  18897.         Include TEXT.BLK
  18898. C
  18899. C     WRITE A LINE TO OUTPUT IGNORING TRAILING BLANKS
  18900. C
  18901.         Include FILES.BLK
  18902.         Include BLNKFL.BLK
  18903.         Include MISC.BLK
  18904.       INTEGER STRING(1)
  18905.       BLNKFL = .TRUE.
  18906.       NW = (NUMC-1)/CHPWD
  18907.       NW = NW + 1
  18908.       NEND = NW
  18909.       DO 10 I=1,NEND
  18910.       IF(STRING(NW).NE.IBLANK) GO TO 20
  18911.       NW = NW - 1
  18912.    10 CONTINUE
  18913.       BLNKFL = .FALSE.
  18914.       RETURN
  18915.    20 CONTINUE
  18916.       WRITE (NOUTR,30)(STRING(I),I=1,NW)
  18917.    30 FORMAT(33A4)
  18918.       RETURN
  18919.       END
  18920.       SUBROUTINE STATUS(FILE,LFS)
  18921.         Include TEXT.BLK
  18922.       CHARACTER*7 FILE
  18923.       LOGICAL EX
  18924.       LFS = 0
  18925.       INQUIRE(FILE=FILE,EXIST=EX)
  18926.       IF(EX) LFS = 1
  18927.       RETURN
  18928.       END
  18929.       SUBROUTINE STRMOV(IST1,IPOS1,NCH,IST2,IPOS2)
  18930.         Include TEXT.BLK
  18931. C
  18932. C  PURPOSE:   MOVE A STRING OF CHARACTERS FROM ONE ARRAY TO ANOTHER
  18933. C
  18934. C  PARAMETERS:
  18935. C     IST1----ORIGINAL STRING WITH THE CHARACTERS TO BE MOVED
  18936. C     IPOS1---STARTING POSITION WITHIN THAT STRING
  18937. C     NCH-----NUMBER OF CHARACTERS TO MOVE
  18938. C     IST2----STRING TO RECEIVE THE CHARACTERS
  18939. C     IPOS2---STARTING POSITION WITHIN THAT STRING
  18940. C
  18941.       CHARACTER*1 IST1(1),IST2(1)
  18942.       INTEGER C1,C2
  18943. C
  18944. C  MAKE SURE THAT THINGS LOOK OK.
  18945. C
  18946.       IF(NCH.LE.0) RETURN
  18947.       C1 = IPOS1
  18948.       C2 = IPOS2
  18949. C
  18950. C  MOVE THE CHARACTERS FROM THE FIRST STRING TO THE SECOND.
  18951. C
  18952.       DO 100 I=1,NCH
  18953.       IST2(C2) = IST1(C1)
  18954.       C1 = C1 + 1
  18955.       C2 = C2 + 1
  18956.   100 CONTINUE
  18957.       RETURN
  18958.       END
  18959.       SUBROUTINE SUBREL
  18960.         Include TEXT.BLK
  18961. C
  18962. C  THIS ROUTINE FINDS THE DIFFERENCE OF TWO RELATIONS BASED UPON
  18963. C  ATTRIBUTES.  THE RESULT FROM THIS PROCESS IS A PHYSICAL
  18964. C  RELATION WHICH HAS ALL TUPLES FROM THE SECOND RELATION WHICH
  18965. C  DO NOT HAVE MATCHES IN THE FIRST.
  18966. C
  18967. C  THE SYNTAX FOR THE SUBTRACT COMMAND IS:
  18968. C
  18969. C   SUBTRACT REL1 FROM REL2 FORMING REL3 [USING ATTR1 ATTR2...ATTR-N]
  18970. C
  18971. C
  18972.         Include RMATTS.BLK
  18973.         Include RMKEYW.BLK
  18974.         Include CONST4.BLK
  18975.         Include FLAGS.BLK
  18976.         Include RIMCOM.BLK
  18977.         Include RIMPTR.BLK
  18978.         Include TUPLER.BLK
  18979.         Include TUPLEA.BLK
  18980.         Include FILES.BLK
  18981.         Include BUFFER.BLK
  18982.         Include WHCOM.BLK
  18983.         Include MISC.BLK
  18984. C
  18985.       INTEGER PTABLE
  18986.       LOGICAL EQKEYW
  18987.         Include DCLAR1.BLK
  18988.         Include DCLAR3.BLK
  18989. C
  18990. C  CALL RMDBLK TO MAKE SURE DATABASE MAY BE MODIFIED
  18991. C
  18992.       CALL RMDBLK(DBNAME)
  18993.       IF(RMSTAT.EQ.0) GO TO 50
  18994.       CALL WARN(RMSTAT,DBNAME,0)
  18995.       GO TO 9999
  18996. C
  18997. C  LOCAL ARRAYS AND VARIABLES :
  18998. C
  18999. C  PTABLE (MATRIX 10) USED TO CONTROL POINTERS
  19000. C        ROWS1,2 -- ATTRIBUTE NAME
  19001. C        ROW3 -- ATTRIBUTE LOCATION IN RELATION 1
  19002. C        ROW4 -- ATTRIBUTE LOCATION IN RELATION 2
  19003. C        ROW5 -- ATTRIBUTE LOCATION IN RELATION 3
  19004. C        ROW6 -- LENGTH IN WORDS
  19005. C        ROW7 -- ATTRIBUTE TYPE
  19006. C
  19007. C  EDIT COMMAND SYNTAX
  19008. C
  19009.    50 CONTINUE
  19010.       CALL BLKCLN
  19011.       NS = 0
  19012.       IF(.NOT.EQKEYW(3,KWFROM,4)) GO TO 9900
  19013.       IF(.NOT.EQKEYW(5,KWFORM,7)) GO TO 9900
  19014.       ITEMS = LXITEM(IDUMMY)
  19015.       IF(ITEMS.GT.6 .AND. .NOT.EQKEYW(7,KWUSIN,5)) GO TO 9900
  19016. C
  19017. C  KEYWORD SYNTAX OKAY
  19018. C
  19019.       RNAME1 = BLANK
  19020.       CALL LXSREC(2,1,8,RNAME1,1)
  19021.       I = LOCREL(RNAME1)
  19022.       IF(I.EQ.0) GO TO 100
  19023. C
  19024. C  MISSING FIRST RELATION.
  19025. C
  19026.       CALL WARN(1,RNAME1,0)
  19027.       GO TO 9999
  19028.   100 CONTINUE
  19029. C
  19030. C  SAVE DATA ABOUT RELATION 1
  19031. C
  19032.       I1 = LOCPRM(RNAME1,1)
  19033.       IF(I1.EQ.0) GO TO 110
  19034.       CALL WARN(9,RNAME1,0)
  19035.       GO TO 9999
  19036.   110 CONTINUE
  19037.       NCOL1 = NCOL
  19038.       NATT1 = NATT
  19039.       RNAME2 = BLANK
  19040.       CALL LXSREC(4,1,8,RNAME2,1)
  19041.       I = LOCREL(RNAME2)
  19042.       IF(I.EQ.0) GO TO 200
  19043. C
  19044. C  MISSING SECOND RELATION.
  19045. C
  19046.       CALL WARN(1,RNAME2,0)
  19047.       GO TO 9999
  19048.   200 CONTINUE
  19049. C
  19050. C  SAVE DATA ABOUT RELATION 2
  19051. C
  19052.       I2 = LOCPRM(RNAME2,1)
  19053.       IF(I2.EQ.0) GO TO 210
  19054.       CALL WARN(9,RNAME2,0)
  19055.       GO TO 9999
  19056.   210 CONTINUE
  19057.       NCOL2 = NCOL
  19058.       NATT2 = NATT
  19059.       RPW2 = RPW
  19060.       MPW2 = MPW
  19061. C
  19062. C  CHECK FOR LEGAL RNAME3
  19063. C
  19064.       IF((LXLENC(6).GE.1).AND.(LXLENC(6).LE.8)) GO TO 250
  19065.       CALL WARN(7,KWRELA,BLANK)
  19066.       GO TO 9999
  19067.   250 CONTINUE
  19068. C
  19069. C  CHECK FOR DUPLICATE RELATION 3
  19070. C
  19071.       RNAME3 = BLANK
  19072.       CALL LXSREC(6,1,8,RNAME3,1)
  19073.       I = LOCREL(RNAME3)
  19074.       IF(I.NE.0) GO TO 300
  19075. C
  19076. C  ERROR
  19077. C
  19078.       WRITE(NOUT,9000)
  19079.  9000 FORMAT(55H -ERROR- RESULTANT RELATION DOES NOT HAVE A UNIQUE NAME)
  19080.       GO TO 9999
  19081. C
  19082. C  CHECK USER READ SECURITY
  19083. C
  19084.   300 CONTINUE
  19085.       IF((I1.NE.0).OR.(I2.NE.0)) GO TO 9999
  19086. C
  19087. C  RELATION NAMES OKAY -- CHECK THE ATTRIBUTES
  19088. C
  19089. C  SET UP PTABLE IN MATRIX POSITION 10
  19090. C
  19091.       CALL BLKDEF(10,7,NATT2)
  19092.       PTABLE = BLKLOC(10)
  19093.       NATT3 = 0
  19094.       IF(ITEMS.EQ.6) GO TO 500
  19095. C
  19096. C  SUBTRACT ON SOME OF THE ATTRIBUTES
  19097. C
  19098.       IF(ITEMS-7.LE.NATT2) GO TO 350
  19099.       WRITE(NOUT,9001)
  19100.  9001 FORMAT(38H -ERROR- TOO MANY ATTRIBUTES SPECIFIED)
  19101.       GO TO 9999
  19102.   350 CONTINUE
  19103.       IJ = 1
  19104.       DO 400 I=8,ITEMS
  19105. C
  19106. C  RETRIEVE ATTRIBUTE LENGTH FOR OLD ATTRIBUTE
  19107. C
  19108. C
  19109. C  SEE IF IT FROM RELATION 1.
  19110. C
  19111.       ANAME = BLANK
  19112.       CALL LXSREC(I,1,8,ANAME,1)
  19113.       ICHK1 = LOCATT(ANAME,RNAME1)
  19114. C
  19115. C  SEE IF IT IS FROM RELATION 2.
  19116. C
  19117.       ICHK2 = LOCATT(ANAME,RNAME2)
  19118.       IF(ICHK2.NE.0) GO TO 450
  19119. C
  19120. C  ATTRIBUTE IS OKAY -- SET UP PTABLE
  19121. C
  19122.       CALL ATTGET(ISTAT)
  19123.       NATT3 = NATT3 + 1
  19124.       BUFFER(PTABLE) = LXWREC(I,1)
  19125.       BUFFER(PTABLE+1) = LXWREC(I,2)
  19126.       BUFFER(PTABLE+3) = ATTCOL
  19127.       BUFFER(PTABLE+4) = IJ
  19128.       NWORDS = ATTWDS
  19129.       BUFFER(PTABLE+5) = ATTLEN
  19130.       IF(NWORDS.EQ.0) NWORDS = 1
  19131.       IJ = IJ + NWORDS
  19132.       BUFFER(PTABLE+6) = ATTYPE
  19133.       IF(ICHK1.NE.0) GO TO 360
  19134.       ICHK1 = LOCATT(ANAME,RNAME1)
  19135.       CALL ATTGET(ISTAT)
  19136.       BUFFER(PTABLE+2) = ATTCOL
  19137.   360 CONTINUE
  19138.       PTABLE = PTABLE + 7
  19139. C
  19140.   400 CONTINUE
  19141.       ICT = IJ - 1
  19142.       GO TO 555
  19143. C
  19144. C  ATTRIBUTE WAS NOT IN RELATION 2
  19145. C
  19146.   450 CONTINUE
  19147.       CALL WARN(3,ANAME,RNAME2)
  19148.       GO TO 9999
  19149. C
  19150. C  SUBTRACT IS ON ALL ATTRIBUTES
  19151. C
  19152.   500 CONTINUE
  19153.       ICT = 1
  19154. C
  19155. C  STORE DATA FROM RELATION 2 IN PTABLE
  19156. C
  19157.       I = LOCATT(BLANK,RNAME2)
  19158.       DO 525 I=1,NATT2
  19159.       CALL ATTGET(ISTAT)
  19160.       IF(ISTAT.NE.0) GO TO 525
  19161.       NATT3 = NATT3 + 1
  19162.       BUFFER(PTABLE) = IBLANK
  19163.       CALL STRMOV(ATTNAM,1,8,BUFFER(PTABLE),1)
  19164.       BUFFER(PTABLE+3) = ATTCOL
  19165.       BUFFER(PTABLE+4) = ICT
  19166.       NWORDS = ATTWDS
  19167.       BUFFER(PTABLE+5) = ATTLEN
  19168.       IF(NWORDS.EQ.0) NWORDS = 1
  19169.       ICT = ICT + NWORDS
  19170.       BUFFER(PTABLE+6) = ATTYPE
  19171.       PTABLE = PTABLE + 7
  19172.   525 CONTINUE
  19173. C
  19174. C  MARK COMMON ATTRIBUTES FROM RELATION 1
  19175. C
  19176. C
  19177. C  FIRST CHECK TO SEE IF ATTRIBUTE IS ALREADY IN PTABLE
  19178. C
  19179.       KQ1 = BLKLOC(10) - 7
  19180.       DO 550 I=1,NATT2
  19181.       KQ1 = KQ1 + 7
  19182.       J = LOCATT(BUFFER(KQ1),RNAME1)
  19183.       IF(J.NE.0) GO TO 550
  19184. C
  19185. C  ALREADY THERE -- CHANGE THE 2ND POINTER
  19186. C
  19187.       CALL ATTGET(ISTAT)
  19188.       BUFFER(KQ1+2) = ATTCOL
  19189.   550 CONTINUE
  19190.       ICT = ICT - 1
  19191. C
  19192. C  DONE LOADING PTABLE
  19193. C
  19194. C  SEE IF THERE ARE ANY COMMON ATTRIBUTES.
  19195. C
  19196.   555 CONTINUE
  19197.       PTABLE = BLKLOC(10)
  19198.       DO 570 I = 1,NATT3
  19199.       IF((BUFFER(PTABLE+2).NE.0).AND.(BUFFER(PTABLE+3).NE.0)) GO TO 600
  19200.       PTABLE = PTABLE + 7
  19201.   570 CONTINUE
  19202. C
  19203. C  NO COMMON ATTRIBUTES
  19204. C
  19205.       WRITE(NOUT,9002) RNAME1,RNAME2
  19206.  9002 FORMAT(19H -ERROR- RELATIONS ,A8,5H AND ,A8,
  19207.      X26H HAVE NO COMMON ATTRIBUTES)
  19208.       GO TO 9999
  19209. C
  19210. C  PTABLE IS CONSTRUCTED
  19211. C
  19212. C  NOW CREATE ATTRIBUTE AND RELATION TABLES AND THE RELATION
  19213. C
  19214.   600 CONTINUE
  19215. C
  19216. C  SET UP THE WHERE CLAUSE FOR THE SUBTRACT.
  19217. C  THIS IS A DUMMY WHERE CLAUSE USED ONLY BY THE KEY PROCESSING
  19218. C
  19219.       KEYCOL = BUFFER(PTABLE+3)
  19220.       KEYTYP = BUFFER(PTABLE+6)
  19221.       NBOO = -1
  19222.       KATTL(1) = BUFFER(PTABLE+5)
  19223.       KATTY(1) = KEYTYP
  19224.       IF(KEYTYP.EQ.KZIVEC) KATTY(1) = KZINT
  19225.       IF(KEYTYP.EQ.KZRVEC) KATTY(1) = KZREAL
  19226.       IF(KEYTYP.EQ.KZDVEC) KATTY(1) = KZDOUB
  19227.       IF(KEYTYP.EQ.KZIMAT) KATTY(1) = KZINT
  19228.       IF(KEYTYP.EQ.KZRMAT) KATTY(1) = KZREAL
  19229.       IF(KEYTYP.EQ.KZDMAT) KATTY(1) = KZDOUB
  19230.       KOMPOS(1) = 1
  19231.       KSTRT = 0
  19232.       MAXTU = ALL9S
  19233.       LIMTU = ALL9S
  19234. C
  19235. C  SET UP RELATION TABLE.
  19236. C
  19237.       NAME = RNAME3
  19238.       CALL RMDATE(RDATE)
  19239.       NCOL = ICT
  19240.       NCOL3 = ICT
  19241.       NATT = NATT3
  19242.       NTUPLE = 0
  19243.       RSTART = 0
  19244.       REND = 0
  19245.       RPW = RPW2
  19246.       MPW = MPW2
  19247.       CALL RELADD
  19248. C
  19249.       CALL ATTNEW(NAME,NATT)
  19250.       PTABLE = BLKLOC(10)
  19251.       DO 700 K=1,NATT3
  19252.       ATTNAM = BLANK
  19253.       CALL STRMOV(BUFFER(PTABLE),1,8,ATTNAM,1)
  19254.       RELNAM = NAME
  19255.       ATTCOL = BUFFER(PTABLE+4)
  19256.       ATTLEN = BUFFER(PTABLE+5)
  19257.       ATTYPE = BUFFER(PTABLE+6)
  19258.       ATTKEY = 0
  19259.       CALL ATTADD
  19260.       PTABLE = PTABLE + 7
  19261.   700 CONTINUE
  19262. C
  19263. C  SEE IF WE CAN DO KEY PROCESSING.
  19264. C
  19265.       PTABLE = BLKLOC(10) - 7
  19266.       DO 800 K=1,NATT3
  19267.       PTABLE = PTABLE + 7
  19268.       IF(BUFFER(PTABLE+2).EQ.0) GO TO 800
  19269.       IF(BUFFER(PTABLE+3).EQ.0) GO TO 800
  19270.       J = LOCATT(BUFFER(PTABLE),RNAME1)
  19271.       IF(J.NE.0) GO TO 800
  19272.       CALL ATTGET(ISTAT)
  19273.       IF(ATTKEY.EQ.0) GO TO 800
  19274. C
  19275. C  WE FOUND A KEY ELEMENT IN MATN1 WHICH IS COMMON.
  19276. C
  19277.       KSTRT = ATTKEY
  19278.       NS = 2
  19279.       KATTL(1) = BUFFER(PTABLE+5)
  19280.       KATTY(1) = BUFFER(PTABLE+6)
  19281.       KEYCOL = BUFFER(PTABLE+3)
  19282.       GO TO 900
  19283.   800 CONTINUE
  19284.   900 CONTINUE
  19285. C
  19286. C  CALL SUBTRC TO CONSTRUCT MATN3
  19287. C
  19288.       CALL BLKDEF(11,MAXCOL,1)
  19289.       KQ3 = BLKLOC(11)
  19290.       PTABLE = BLKLOC(10)
  19291.       I = LOCREL(RNAME2)
  19292.       CALL SUBTRC(RNAME1,RNAME3,BUFFER(KQ3),NCOL3,NATT3,BUFFER(PTABLE),
  19293.      XKEYCOL,KEYTYP)
  19294.       GO TO 9999
  19295. C
  19296. C  SYNTAX ERROR IN SUBTRACT COMMAND
  19297. C
  19298.  9900 CONTINUE
  19299.       CALL WARN(4,0,0)
  19300. C
  19301. C
  19302. C  DONE WITH SUBTRACT
  19303. C
  19304.  9999 CONTINUE
  19305.       CALL BLKCLR(10)
  19306.       CALL BLKCLR(11)
  19307.       RETURN
  19308.       END
  19309.       SUBROUTINE SUBTRC(RNAME1,RNAME3,MATN3,NCOL3,NATT3,PTABLE,
  19310.      XKEYCOL,KEYTYP)
  19311.         Include TEXT.BLK
  19312. C
  19313. C  THIS ROUTINE PERFORMS THE ACTUAL SUBTRACT BETWEEN
  19314. C  RELATION 1 AND 2 FORMING 3
  19315. C
  19316. C  PARAMETERS:
  19317. C         NAME1---NAME OF THE FIRST RELATION
  19318. C         MATN3---DATA TUPLE FOR RELATION 3
  19319. C         NCOL3---NUMBER OF FIXED LENGTH COLUMNS IN MATN3
  19320. C         NATT3---NUMBER OF ATTRIBUTES IN MATN3
  19321. C         PTABLE--POINTER TABLE FOR THIS SUBTRACT
  19322. C         KEYCOL--COLUMN OF MATN2 USED FOR SUPPLYING KEY VALUES
  19323. C         KEYTYP--ATTRIBUTE TYPE OF MATN1 USED FOR KEY VALUES
  19324.         Include RMATTS.BLK
  19325.         Include FILES.BLK
  19326.         Include TUPLER.BLK
  19327.         Include RIMPTR.BLK
  19328.         Include RIMCOM.BLK
  19329.         Include BUFFER.BLK
  19330.         Include WHCOM.BLK
  19331.         Include DCLAR1.BLK
  19332.       DIMENSION MATN3(1)
  19333.       INTEGER PTABLE(7,1)
  19334.       INTEGER ATTLEN
  19335.       INTEGER ENDCOL
  19336. C
  19337. C  INITIALIZE THE MATRIX POINTERS.
  19338. C
  19339.       IDST = 0
  19340.       IDNEW = 0
  19341.       IDCUR = NID
  19342. C
  19343. C  GET THE PARAMETERS FOR THE FIRST MATRIX.
  19344. C
  19345.       I = LOCREL(RNAME1)
  19346.       IDM1 = NID
  19347.       NSP = 0
  19348.       IF(KSTRT.NE.0) NSP = 2
  19349.       NTUP3 = 0
  19350. C
  19351. C  SEQUENCE THROUGH MATN2.
  19352. C
  19353.   100 CONTINUE
  19354.       IF(IDCUR.EQ.0) GO TO 1000
  19355.       CALL ITOH(N1,N2,IDCUR)
  19356.       IF(N2.EQ.0) GO TO 1000
  19357.       CALL GETDAT(2,IDCUR,MATN2,NCOL2)
  19358.       IF(IDCUR.LT.0) GO TO 1000
  19359. C
  19360. C  MOVE THE COMPARISON VALUE INTO THE WHCOM ARRAYS.
  19361. C
  19362.       CALL ITOH(NCHAR,NWORDS,KATTL(1))
  19363.       IP = MATN2 + KEYCOL - 1
  19364.       IF(NWORDS.NE.0) GO TO 110
  19365. C
  19366. C  SPECIAL GYRATIONS FOR VARIABLE LENGTH STUFF.
  19367. C
  19368.       IP2 = BUFFER(IP)
  19369.       IP = MATN2 + IP2 + 1
  19370.   110 CONTINUE
  19371.       WHRVAL(1) = BUFFER(IP)
  19372.       NID = IDM1
  19373.       NS = NSP
  19374.   200 CONTINUE
  19375.       CALL RMLOOK(MATN1,1,1,NCOL1)
  19376.       IF(RMSTAT.NE.0) GO TO 400
  19377. C
  19378. C  CHECK TO SEE IF THE ATTRIBUTES MATCH.
  19379. C
  19380.       K = 1
  19381.   300 CONTINUE
  19382.       CALL PTRS(IPT1,IPT2,K,NATT3,PTABLE,LEN,ITYPE)
  19383. C
  19384. C  IF K IS 0 WE HAVE LOOKED AT ALL THE COMMON ATTRIBUTES.
  19385. C
  19386.       IF(K.EQ.0) GO TO 100
  19387.       I1 = MATN1 + IPT1 - 1
  19388.  
  19389.       I2 = MATN2 + IPT2 - 1
  19390.       IF(LEN.EQ.0) GO TO 320
  19391.       DO 310 I=1,LEN
  19392.       IF(BUFFER(I1).NE.BUFFER(I2)) GO TO 200
  19393.       I1 = I1 + 1
  19394.       I2 = I2 + 1
  19395.   310 CONTINUE
  19396. C
  19397. C  A MATCH. LOOK AT MORE ATTRIBUTES.
  19398. C
  19399.       GO TO 300
  19400. C
  19401. C  VARIABLE LENGTH ATTRIBUTE PROCESSING.
  19402. C
  19403.   320 CONTINUE
  19404.       IPT1 = BUFFER(I1)
  19405.       IPT2 = BUFFER(I2)
  19406.       I1 = MATN1 + IPT1 - 1
  19407.       I2 = MATN2 + IPT2 - 1
  19408.       IF(BUFFER(I1).NE.BUFFER(I2)) GO TO 200
  19409.       LEN = BUFFER(I1)
  19410.       I1 = I1 + 2
  19411.       I2 = I2 + 2
  19412.       DO 340 I=1,LEN
  19413.       IF(BUFFER(I1).NE.BUFFER(I2)) GO TO 200
  19414.       I1 = I1 + 1
  19415.       I2 = I2 + 1
  19416.   340 CONTINUE
  19417.       GO TO 300
  19418. C
  19419. C  OKAY -- NOW LOAD THE DATA.
  19420. C
  19421.   400 CONTINUE
  19422.       ENDCOL = NCOL3
  19423.       DO 900 KLM=1,NATT3
  19424.       KOL2 = PTABLE(4,KLM)
  19425.       KOL3 = PTABLE(5,KLM)
  19426.       ATTLEN = PTABLE(6,KLM)
  19427.       CALL ITOH(NCHAR,NWORDS,ATTLEN)
  19428.       IF(NWORDS.EQ.0) GO TO 700
  19429.       DO 600 I=1,NWORDS
  19430. C
  19431. C  LOAD THE ATTRIBUTE FROM MATN2.
  19432. C
  19433.       I2 = MATN2 + KOL2 - 1
  19434.       MATN3(KOL3) = BUFFER(I2)
  19435.       KOL3 = KOL3 + 1
  19436.       KOL2 = KOL2 + 1
  19437.   600 CONTINUE
  19438.       GO TO 900
  19439.   700 CONTINUE
  19440.       ENDCOL = ENDCOL + 1
  19441.       MATN3(KOL3) = ENDCOL
  19442.       I2 = MATN2 + KOL2 - 1
  19443.       KOL2 = BUFFER(I2)
  19444.       I2 = MATN2 + KOL2 - 1
  19445.       NWORDS = BUFFER(I2)
  19446.       MATN3(ENDCOL) = NWORDS
  19447.       NWORDS = NWORDS + 1
  19448.       DO 800 I=1,NWORDS
  19449.       ENDCOL = ENDCOL + 1
  19450.       I2 = I2 + 1
  19451.       MATN3(ENDCOL) = BUFFER(I2)
  19452.   800 CONTINUE
  19453.   900 CONTINUE
  19454.       CALL ADDDAT(3,IDNEW,MATN3,ENDCOL)
  19455.       IF(IDST.EQ.0) IDST = IDNEW
  19456.       NTUP3 = NTUP3 + 1
  19457. C
  19458. C  LOOK FOR MORE IN MATN2.
  19459. C
  19460.       GO TO 100
  19461. C
  19462. C  ALL DONE.
  19463. C
  19464.  1000 CONTINUE
  19465.       I = LOCREL(RNAME3)
  19466.       CALL RELGET(ISTAT)
  19467.       RSTART = IDST
  19468.       REND = IDNEW
  19469.       NTUPLE = NTUP3
  19470.       CALL RELPUT
  19471.       NUM = NTUP3
  19472.       WRITE(NOUT,9000) NUM
  19473.  9000 FORMAT(31H SUCCESSFUL SUBTRACT OPERATION ,
  19474.      XI6,15H ROWS GENERATED)
  19475. C
  19476. C  RETURN
  19477. C
  19478.       RETURN
  19479.       END
  19480.       SUBROUTINE SWCON(BUFFER,LBUF,INFIL,OUTFIL,IERR)
  19481.         Include TEXT.BLK
  19482. C
  19483. C  PURPOSE  CONTROLLING ROUTINE FOR SORT
  19484. C
  19485. C  METHOD   ROUTINE DETERMINES WHICH KIND
  19486. C           OF SORT IS REQUIRED AND CALLS
  19487. C           APPLICABLE ROUTINE TO CARRY OUT SORT
  19488. C           THE 4 TYPES OF SORT THAT ARE AVAILABLE ARE
  19489. C
  19490. C           INCORE,LINK LIST (HART)
  19491. C           INCORE,IN SITU POINTERS
  19492. C           OUT-OF-CORE,FIXED TUPLE SIZE
  19493. C           OUT-OF-CORE,VARIABLE TUPLE SIZE
  19494. C           INCORE SORT IS FIXED OR VARIABLE
  19495. C           LTUPLE TUPLES
  19496. C
  19497. C  TIMING   UNKNOWN
  19498. C
  19499. C  DEFINITION OF VARIABLES
  19500. C
  19501. C  INFIL   FILE NAME OF FILE (SEQ) WHICH    (INT,I)
  19502. C          CONTAINS INPUT TUPLES
  19503. C         INFIL IS UNFORMATTED (BINARY)
  19504. C         EACH TUPLE IS WRITTEN AS A
  19505. C         RECORD AS FOLLOWS
  19506. C         FOR FIXED LENGTH RECORDS
  19507. C           WRITE(INFIL) (TUP(I),I=1,LTUPLE)
  19508. C         FOR VARIABLE LENGTH RECORDS
  19509. C           WRITE(INFIL) L,(TUP(I),I=1,L)
  19510. C
  19511. C  OUTFIL  FILE NAME OF FILE (SEQ) WHICH    (INT,I)
  19512. C          CONTAINS OUTPUT (SORTED) TUPLES
  19513. C          OUTFIL MAY EQ INFIL
  19514. C          FORMAT OF OUTFIL IS THE
  19515. C          SAME AS THAT OF INFIL
  19516. C
  19517. C  IERR    ERROR CONDITION                  (INT,O)
  19518. C           0 NORMAL RETURN
  19519. C           1 ERROR IN FILE READ
  19520. C           2 ERROR IN FILE WRITE
  19521. C
  19522.         Include CONST8.BLK
  19523.         Include SRTCOM.BLK
  19524.       INTEGER OUTFIL,INFIL
  19525.       REAL*8 SCFIL1,SCFIL2
  19526. C
  19527. C  THE FOLLOWING THREE EXEC STATEM TO BE REPL
  19528. C  WITH UPDATE *CALL
  19529. C
  19530.       INTEGER BUFFER(1)
  19531.       INTEGER DPRU
  19532.         Include DATA4.BLK
  19533. C
  19534. C  ESTABLISH RANDOM SCRATCH FILE NAMES
  19535. C
  19536.       SCFIL1 = K8ZZ98
  19537.       SCFIL2 = K8ZZ99
  19538.       REWIND INFIL
  19539.       I1 = 2*NSORT + 12
  19540.       IF(NSORT .GT. 2000) I1 = I1 + 89
  19541.    20 CONTINUE
  19542.       I3 = LTUPLE
  19543.       IF(FIXLT) I3 = LTUPLE*NSORT
  19544.       IF(I1+I3 .GT. LBUF) GO TO 100
  19545. C
  19546. C  INCORE SORT,HART METHOD
  19547. C
  19548.       CALL SWHART(INFIL,OUTFIL,BUFFER,I1,IERR)
  19549.       GO TO 400
  19550.   100 CONTINUE
  19551.       IF(NSORT+I3 .GT. LBUF) GO TO 200
  19552. C
  19553. C  INCORE SORT,POINTERS IN SITU
  19554. C
  19555.       CALL SWINPO(INFIL,OUTFIL,BUFFER,IERR)
  19556.       GO TO 400
  19557.   200 CONTINUE
  19558. CC
  19559. C  OUT-OF-CORE SORT
  19560. C
  19561.       IF( FIXLT) GO TO 300
  19562. C
  19563. C  VARIABLE LENGTH OUT-OF-CORE SORT
  19564. C
  19565.       CALL SWVLFS(INFIL,OUTFIL,SCFIL1,SCFIL2,
  19566.      X                 BUFFER,LBUF,LPRU,DPRU,IERR)
  19567.       GO TO 400
  19568.   300 CONTINUE
  19569. C
  19570. C  FIXED TUPLE LENGTH,OUT-OF-CORE SORT
  19571. C
  19572.       CALL SWFLFS(INFIL,OUTFIL,SCFIL1,SCFIL2,
  19573.      X                 BUFFER,LBUF,LPRU,DPRU,IERR)
  19574.   400 CONTINUE
  19575.       REWIND OUTFIL
  19576.       RETURN
  19577.       END
  19578.       SUBROUTINE SWCOST(NOPASS,NREC,LREC,SORD,COST)
  19579.         Include TEXT.BLK
  19580. C
  19581. C  PURPOSE  DETERMINE COST OF A SORTING STRATEGY
  19582. C
  19583. C  METHOD   COMPUTE COST FROM FORMULA
  19584. C           COST=NOPASS*(2*NREC*(IOPOSC+LREC*IOTRAC) +
  19585. C                 + NSORT*NSOVAR*.5*SORD*COCOST
  19586. C                 + NREC*LREC*MOCOFI
  19587. C                 + NREC*(LREC-1)*MOCOAD)
  19588. C
  19589. C  DEFINITION OF PARAMETERS
  19590. C
  19591. C  NOPASS  NUMBER OF SORT PASSES EXCLUDING SEQUENTIAL     (INT,I)
  19592. C          READ AND WRITE (FIRST AND LAST)
  19593. C          EACH PASS CONSISTS OF ONE READ AND ONE WRITE
  19594. C
  19595. C  NREC   NUMBER OF PAGES ON SORT SCRATCH FILE           (INT,I)
  19596. C
  19597. C  LREC    LENGTH OF A SORT PAGE                          (INT,I)
  19598. C
  19599. C  SORD     SORT ORDER,I.E. NUMBER OF INPUT SORT BLOCKS   (INT,I)
  19600. C           IN CORE DURING MERGE PHASE
  19601. C
  19602. C  COST FORMULA PARAMETERS
  19603. C
  19604. C  IOPOSC  = RELATIVE COST FOR I OR O POSITIONING
  19605. C
  19606. C  IOTRAC  = RELATIVE COST OF I OR O TRANSFER OF ONE WORD
  19607. C
  19608. C  COCOST  = RELATIVE COST OF COMPARING TWO SINGLE VARIABLES
  19609. C
  19610. C  MOCOFI  = RELATIVE COST OF MOVING FIRST WORD OF ONE
  19611. C            BLOCK IN CORE
  19612. C
  19613. C  MOCOAD  = RELATIVE COST OF MOVING ADDITIONAL WORDS
  19614. C            OF THE BLOCK IN CORE
  19615. C
  19616.         Include SRTCOM.BLK
  19617.       INTEGER SORD
  19618.       REAL IOPOSC,IOTRAC,COCOST,MOCOFI,MOCOAD
  19619.         Include DATA5.BLK
  19620.       COST = NOPASS*(2*NREC*(IOPOSC+LREC*IOTRAC)
  19621.      X      +NSORT*NSOVAR*.5*SORD*COCOST
  19622.      X      +NREC*MOCOFI+NREC*(LREC-1)*MOCOAD)
  19623.       RETURN
  19624.       END
  19625.       SUBROUTINE SWFILO(BUFFER,LTUP,LREC,NTUREC,NINTUP,
  19626.      X                  INFIL,OUTFIL)
  19627.         Include TEXT.BLK
  19628. C
  19629. C  PURPOSE  LOADING PASS FOR OUT-OF-CORE SORT
  19630. C           OF FIXED LENGTH TUPLES
  19631. C
  19632. C  TIMING   UNKNOWN
  19633. C
  19634. C  DEFINITION OF VARIABLES
  19635. C
  19636. C  BUFFER   CORE SCRATCH AREA OF                  (SCRATCH)
  19637. C           SUFFICIENT LENGTH
  19638. C              GE NINTUP*(1+LREC)+NTUREC*LREC
  19639. C
  19640. C  LTUP     LENGTH, IN WORDS, OF INDIVIDUAL       (INT,I)
  19641. C           TUPLE
  19642. C
  19643. C  LREC     LENGTH, IN WORDS, OF OUTPUT RECORD    (INT,I)
  19644. C
  19645. C  NTUREC   NUMBER OF TUPLES PER OUTPUT           (INT,I)
  19646. C           RECORD
  19647. C
  19648. C  NINTUP     NUMBER OF TUPLES                      (INT,I)
  19649. C           IN ONE SORT CHAIN
  19650. C
  19651. C
  19652. C  INFIL   FILE NAME OF FILE (SEQ) WHICH    (INT,I)
  19653. C           CONTAINS INPUT TUPLES
  19654. C           INFIL IS UNFORMATTED (BINARY)
  19655. C           EACH TUPLE IS WRITTEN AS A
  19656. C           RECORD AS FOLLOWS
  19657. C           FOR FIXED LENGTH RECORDS
  19658. C             WRITE(INFIL) (TUP(I),I=1,LTUPLE)
  19659. C           FOR VARIABLE LENGTH RECORDS
  19660. C             WRITE(INFIL) L,(TUP(I),I=1,L)
  19661. C
  19662. C  OUTFIL   FET FOR FILE      (RANDOM) WHICH      (INT,I)
  19663. C           CONTAINS CHAINS OF SORTED TUPLES
  19664. C           EACH CHAIN CONTAINS ONE OR MORE BLOCKS
  19665. C           EACH BLOCK CONTAINS
  19666. C            WORD 1   = NO TUPLES IN BLOCK
  19667. C            WORD 2   = CHAIN NO,NEG FOR LAST BLOCK
  19668. C            WORD 3FF = TUPLES INSORTED ORDER
  19669. C
  19670. C
  19671.         Include SRTCOM.BLK
  19672.       INTEGER BUFFER(1),OUTFIL
  19673.       REWIND INFIL
  19674.       I2 = 0
  19675.       J1 = NINTUP*(1+LTUP)
  19676.       I8 = 0
  19677.    10 CONTINUE
  19678.       I8 = I8 + 1
  19679.       I1 = NINTUP
  19680.       DO 20 I=1,NINTUP
  19681.       READ(INFIL) (BUFFER(I1+I3),I3=1,LTUP)
  19682.       I2 = I2 + 1
  19683.       BUFFER(I) = I1 + 1
  19684.       I1 = I1 + LTUP
  19685.       IF(I2 .EQ. NSORT) GO TO 21
  19686.    20 CONTINUE
  19687.       I = NINTUP
  19688.    21 CONTINUE
  19689. C
  19690. C     READ COMPLETE FOR ONE CHAIN - SORT
  19691. C
  19692.       CALL SWICST(BUFFER,BUFFER,I)
  19693. C
  19694. C     SORT COMPLETE - UNLOAD
  19695. C
  19696.       I3 = 0
  19697.    40 CONTINUE
  19698.       I4 = J1 + 2
  19699.       DO 50 I5=1,NTUREC
  19700.       I3 = I3 + 1
  19701.       I7 = BUFFER(I3) - 1
  19702.       DO 45 I6=1,LTUP
  19703.    45 BUFFER(I4+I6) = BUFFER(I7+I6)
  19704.       I4 = I4 + LTUP
  19705.       IF(I3 .EQ. I) GO TO 55
  19706.    50 CONTINUE
  19707.       I5 = NTUREC
  19708.    55 CONTINUE
  19709. C
  19710. C  WRITE ONE RECORD
  19711. C
  19712.       BUFFER(J1+1) = I5
  19713.       I7 = I8
  19714.       IF(I3 .EQ. I) I7 = -I7
  19715.    60 BUFFER(J1+2) = I7
  19716. C
  19717. C  ADD IN RANDOM I/O STUFF
  19718. C
  19719.       CALL RIOOUT(OUTFIL,0,BUFFER(J1+1),LREC,IOS)
  19720.       IF(I3 .LT. I) GO TO 40
  19721.       IF(I2 .LT. NSORT) GO TO 10
  19722. C
  19723. C     SORT PASS COMPLETE FOR ALL CHAINS
  19724. C
  19725.       RETURN
  19726.       END
  19727.       SUBROUTINE SWFLFS(INFIL,OUTFIL,SCFIL1,SCFIL2,
  19728.      X                 BUFFER,LBUF,LPRU,DPRU,IERR)
  19729.         Include TEXT.BLK
  19730. C
  19731. C  PURPOSE  DRIVER FOR OUT-OF-CORE SORT
  19732. C           OF FIXED LENGTH TUPLES
  19733. C
  19734. C  METHOD   A LEAST COST SORT STRATEGY
  19735. C           IS ESTABLISHED BASED UPON
  19736. C           MACHINE DEPENDENT PARAMETERS
  19737. C           THE COST IS BASED UPON
  19738. C           COST FOR POSITIONING ON
  19739. C           MASS STORAGE,MASS STORAGE
  19740. C           TRANSFERS,IN-CORE MOVEMENT
  19741. C           OF DATA AND COMPARISON OF
  19742. C           DATA.
  19743. C           AN N-ARY SORT/MERGE STRATEGY
  19744. C           IS CHOOSEN WHERE 2 LE N LE 9
  19745. C           N IS THE NUMBER OF CHAINS
  19746. C           OF DATA THAT IS MERGED IN
  19747. C           ONE SINGLE MERGE. EACH SORT PASS
  19748. C           MAY REQUIRE SEVERAL SUCH MERGES.
  19749. C
  19750. C
  19751. C
  19752. C
  19753. C  DEFINITION OF VARIABLES
  19754. C
  19755. C  INFIL   FILE NAME OF FILE (SEQ) WHICH    (TEXT,I)
  19756. C          CONTAINS INPUT TUPLES
  19757. C         INFIL IS UNFORMATTED (BINARY)
  19758. C         EACH TUPLE IS WRITTEN AS A
  19759. C         RECORD AS FOLLOWS
  19760. C         FOR FIXED LENGTH RECORDS
  19761. C           WRITE(INFIL) (TUP(I),I=1,LTUPLE)
  19762. C         FOR VARIABLE LENGTH RECORDS
  19763. C           WRITE(INFIL) L,(TUP(I),I=1,L)
  19764. C
  19765. C  OUTFIL  FILE NAME OF FILE (SEQ) WHICH    (TEXT,I)
  19766. C          CONTAINS OUTPUT (SORTED) TUPLES
  19767. C          OUTFIL MAY EQ INFIL
  19768. C          FORMAT OF OUTFIL IS THE
  19769. C          SAME AS THAT OF INFIL
  19770. C
  19771. C  SCFIL1  FILE NAME OF (RAN) SCRATCH FILE  (TEXT,I)
  19772. C
  19773. C  SCFIL2  FILE NAME OF (RAN) SCRATCH FILE  (TEXT,I)
  19774. C          NOTE THAT SCFIL1 MUST NOT BE
  19775. C          EQUAL TO SCFIL2
  19776. C
  19777. C  BUFFER  INCORE SCRATCH AREA              (ANY,SCRATCH)
  19778. C
  19779. C  LBUF    LENGTH OF BUFFER                 (INT,I)
  19780. C
  19781. C  LPRU    QUANTUM LENGTH OF RANDOM         (INT,I)
  19782. C          FILE RECORDS
  19783. C
  19784. C  DPRU    DELTA QUANTUM LENGTH OF          (INT,I)
  19785. C          RANDOM FILE RECORDS.
  19786. C          THE LENGTH OF SUCH A RECORD
  19787. C          MUST EQUAL
  19788. C          I*LPRU+DPRU
  19789. C
  19790. C  IERR    ERROR CONDITION                  (INT,O)
  19791. C           0 NORMAL RETURN
  19792. C           1 ERROR IN FILE READ
  19793. C           2 ERROR IN FILE WRITE
  19794. C
  19795. C
  19796. C  DEFINITION OF LOCAL VARIABLES
  19797. C
  19798. C  I1     SCRATCH
  19799. C  I2     SCRATCH,NO OF PAGES IN INITIAL
  19800. C         OFLOADING
  19801. C  I3     SCRATCH,NO OF SORT PASSES,NOT COUNTING
  19802. C         ACTIONS ON SEQUENTIAL FILES
  19803. C         OF WHOLE RANDOM FILES
  19804. C  I4     SCRATCH
  19805. C  I5     SCRATCH
  19806. C  I6     LOW COST SORT ORDER
  19807. C  I7     NO OF INCORE PAGES IN INITIAL
  19808. C         PASS WHERE SEQUENTIAL FILE IS
  19809. C         OFFLOADED
  19810. C  I8     SCRATCH,NO OF TUPLES PER RAN FILE PAGE
  19811. C  I9     SCRATCH,NO OF PAGES ON RANDOM FILES
  19812. C  I10    SCRATCH,LENGTH OF RANDOM FILE PAGE
  19813. C  COST   COST OF OPTIMUM SORT STRATEGY
  19814. C  NTUREC NO OF TUPLES PER RANDOM FILE PAGE
  19815. C  NRECS  NO OF PAGES ON RANDOM SCRATCH FILE
  19816. C  LREC   LENGTH OF RANDOM FILE PAGE
  19817. C  NPASS  NO OF SORT PASSES,NOT COUNTING
  19818. C         ACTIONS ON SEQUENTIAL FILES
  19819. C         ONE PASS CONTAINS ONE COMPLETE
  19820. C         WRITE AND ONE COMPLETE READ
  19821. C         OF WHOLE RANDOM FILES
  19822. C
  19823.         Include SRTCOM.BLK
  19824.       DIMENSION BUFFER(1)
  19825.       INTEGER DPRU,OUTFIL
  19826.       INTEGER SCARR1,SCARR2
  19827.       REAL*8 SCFIL1,SCFIL2
  19828.       INTEGER CHAIN1,OUTREC
  19829.       LOGICAL SWITCH
  19830.       LTUP = LTUPLE
  19831.       I6 = 0
  19832.       I1 = 2*LPRU
  19833.       I11 = 2*DPRU
  19834.       DO 100 I=2,9
  19835.       I1 = I1 + LPRU
  19836.       I11 = I11 + DPRU
  19837.       I10 = LPRU*((LBUF-I11)/I1) + DPRU
  19838.       IF(I10 .LT. LTUP) GO TO 110
  19839.       I8 = (I10-2)/LTUP
  19840.       I2 = (LBUF-I10)/(I10+I8)
  19841. C
  19842. C  I2 IS NO OF INCORE BLOCKS IN
  19843. C     INITIAL PASS
  19844. C
  19845.       I9 =(NSORT+I8-1)/I8
  19846.       I3 = 1
  19847.       I4 = I2
  19848.    10 CONTINUE
  19849.       I5 = I4
  19850.       I4 = I4*I + I5
  19851.       IF (I4 .GE. I9) GO TO 20
  19852.       I4 = I4 - I5
  19853.       I3 = I3 + 1
  19854.       GO TO 10
  19855.    20 CONTINUE
  19856. C
  19857.       CALL SWCOST(I3,I9,I10,I,A1)
  19858.       IF(I6 .GT. 0) GO TO 30
  19859.       GO TO 35
  19860.    30 CONTINUE
  19861.       IF(A1 .GE. COST) GO TO 90
  19862.    35 COST = A1
  19863.       I7 = I2
  19864.       I6 = I
  19865.       NTUREC = I8
  19866.       NRECS = I9
  19867.       NPASS = I3
  19868.       LREC = I10
  19869.    90 CONTINUE
  19870.       IF(I3 .EQ. 1) GO TO 110
  19871.   100 CONTINUE
  19872.   110 CONTINUE
  19873. C
  19874. C  OPTIMUM SORT STRATEGY DETERMINED
  19875. C
  19876. C  OPEN SORT SCRATCH FILES
  19877. C
  19878.       SCARR1 = 35
  19879.       SCARR2 = 36
  19880.       CALL DROPF(SCFIL1)
  19881.       CALL DROPF(SCFIL2)
  19882.       CALL RIOOPN(SCFIL1,SCARR1,LREC,IOS)
  19883.       CALL RIOOPN(SCFIL2,SCARR2,LREC,IOS)
  19884.       CALL SWFILO(BUFFER,LTUP,LREC,NTUREC,I7*NTUREC,
  19885.      X            INFIL,SCARR1)
  19886. C
  19887. C     NPASS IS THE NUMBER OF RANDOM TO RANDOM MERGES
  19888. C     NI IS THE NUMBER OF CHAINS ON THE INPUT FILE
  19889. C     NO IS THE NUMBER OF CHAINS ON THE OUTPUT FILE
  19890. C     NCHAIN IS THE NUMBER OF CHAINS TO MERGE
  19891. C     LCHAIN IS THE NUMBER OF PAGES PER INPUT CHAIN
  19892. C
  19893.       LCHAIN = I7
  19894.       NCHAIN = I6
  19895.       NI = (NRECS-1)/LCHAIN
  19896.       NI = NI + 1
  19897.       NO = NI
  19898.       SWITCH = .TRUE.
  19899. C
  19900. C     OUTER LOOP ON THE NUMBER OF PASSES
  19901. C
  19902.       NPASS = NPASS - 1
  19903.       IF(NPASS.EQ.0) GO TO 250
  19904.       DO 200 I=1,NPASS
  19905.       NI = NO
  19906.       NO = (NI-1)/NCHAIN
  19907.       NO = NO + 1
  19908.       SWITCH = .NOT. SWITCH
  19909.       INC = LCHAIN*NCHAIN
  19910. C
  19911. C     INNER LOOP ON NUMBER OF OUTPUT CHAINS
  19912. C
  19913.       DO 150 J=1,NO
  19914.       CHAIN1 = (J-1)*INC + 1
  19915.       OUTREC = CHAIN1
  19916.       IF(I.EQ.1) OUTREC = 0
  19917.       NCH = NCHAIN
  19918.       IF(J.EQ.NO) NCH = NI - (NO-1)*NCHAIN
  19919.       IF(SWITCH) CALL SWSMFL(BUFFER,CHAIN1,NCH,LCHAIN,OUTREC,J,NTUREC,
  19920.      X       LTUP,LREC,SCARR2,SCARR1)
  19921.       IF(.NOT.SWITCH) CALL SWSMFL(BUFFER,CHAIN1,NCH,LCHAIN,OUTREC,J,
  19922.      X       NTUREC,LTUP,LREC,SCARR1,SCARR2)
  19923.   150 CONTINUE
  19924.       LCHAIN = LCHAIN * NCHAIN
  19925.   200 CONTINUE
  19926.   250 CONTINUE
  19927. C
  19928. C     CALL SWUNLO TO CREATE OUTPUT SEQUENTIAL FILE
  19929. C
  19930.       CHAIN1 = 1
  19931.       OUTREC = 1
  19932.       NCH = NO
  19933.       IF(SWITCH) CALL SWUNLO(BUFFER,CHAIN1,NCH,LCHAIN,
  19934.      X      LTUP,LREC,SCARR1,OUTFIL)
  19935.       IF(.NOT.SWITCH) CALL SWUNLO(BUFFER,CHAIN1,NCH,LCHAIN,
  19936.      X      LTUP,LREC,SCARR2,OUTFIL)
  19937. C
  19938. C     RETURN THE SCRATCH RANDOM FILES
  19939. C
  19940.       CALL DROPF(SCFIL1)
  19941.       CALL DROPF(SCFIL2)
  19942.       RETURN
  19943.       END
  19944.       SUBROUTINE SWHART(INFIL,OUTFIL,BUFFER,LLL,IERR)
  19945.         Include TEXT.BLK
  19946.         Include SRTCOM.BLK
  19947.       INTEGER BUFFER(1)
  19948.       INTEGER OUTFIL
  19949. C
  19950. C  PURPOSE  CONTROLLING ROUTINE FOR IN-CORE HART SORT
  19951. C
  19952. C  TIMING   UNKNOWN
  19953. C
  19954. C  DEFINITION OF VARIABLES
  19955. C
  19956. C  INFIL   FILE NAME OF FILE (SEQ) WHICH    (INT,I)
  19957. C          CONTAINS INPUT TUPLES
  19958. C         INFIL IS UNFORMATTED (BINARY)
  19959. C         EACH TUPLE IS WRITTEN AS A
  19960. C         RECORD AS FOLLOWS
  19961. C         FOR FIXED LENGTH RECORDS
  19962. C           WRITE(INFIL) (TUP(I),I=1,LTUPLE)
  19963. C         FOR VARIABLE LENGTH RECORDS
  19964. C           WRITE(INFIL) L,(TUP(I),I=1,L)
  19965. C
  19966. C  OUTFIL  FILE NAME OF FILE (SEQ) WHICH    (INT,I)
  19967. C          CONTAINS OUTPUT (SORTED) TUPLES
  19968. C          OUTFIL MAY EQ INFIL
  19969. C          FORMAT OF OUTFIL IS THE
  19970. C          SAME AS THAT OF INFIL
  19971. C
  19972. C  BUFFER  CORE BUFFER TO USE FOR SORT      (ANY,SCR)
  19973. C
  19974. C  LLL     LENGTH OF LINK LIST              (INT,I)
  19975. C
  19976. C  IERR    ERROR CONDITION                  (INT,O)
  19977. C           0 NORMAL RETURN
  19978. C           1 ERROR IN FILE READ
  19979. C           2 ERROR IN FILE WRITE
  19980. C
  19981.       IF(FIXLT) GO TO 10
  19982. C
  19983. C  INCORE,VAR LENGTH
  19984. C
  19985.       I1 = LLL + 1
  19986.       DO 5 I2=1,NSORT
  19987.       BUFFER(I2) = I1 + 1
  19988.       READ(INFIL) I4,(BUFFER(I1+I5),I5=1,I4)
  19989.       BUFFER(I1) = I4
  19990.     5 I1 = I1 + I4 + 1
  19991.       GO TO 20
  19992.    10 CONTINUE
  19993. C
  19994. C  INCORE,FIXED LENGTH TUPLES
  19995. C
  19996.       I1 = LLL
  19997.       DO 15 I2=1,NSORT
  19998.       BUFFER(I2)= I1 + 1
  19999.       READ(INFIL) (BUFFER(I1+I4),I4=1,LTUPLE)
  20000.    15 I1 = I1 + LTUPLE
  20001.    20 CONTINUE
  20002. C
  20003. C  READ COMPLETED,SORT
  20004. C
  20005.       KGOTO = VARTYP(1)
  20006.       GO TO(21,22,23,23),KGOTO
  20007.    21 CALL SWHRTI(BUFFER(1),BUFFER(NSORT+1),BUFFER)
  20008.       GO TO 24
  20009.    22 CALL SWHRTR(BUFFER(1),BUFFER(NSORT+1),BUFFER)
  20010.       GO TO 24
  20011.    23 CALL SWHRTD(BUFFER(1),BUFFER(NSORT+1),BUFFER)
  20012.    24 CONTINUE
  20013. C
  20014. C  SORT COMPLETE,UNLOAD
  20015. C
  20016.       REWIND OUTFIL
  20017.       I5 = 2*NSORT + 1
  20018.       IF(FIXLT) GO TO 40
  20019. C
  20020. C  VARIABLE LENGTH TUPLES
  20021. C
  20022.       DO 35 I2=1,NSORT
  20023.       I3 = BUFFER(I5)
  20024.       I5 = NSORT + I3
  20025.       I1 = BUFFER(I3) - 1
  20026.       I4 = BUFFER(I1)
  20027.       WRITE(OUTFIL) I4,(BUFFER(I3+I1),I3=1,I4)
  20028.    35 CONTINUE
  20029.       RETURN
  20030.    40 CONTINUE
  20031. C
  20032. C  WRITE FIXED LENGTH TUPLES
  20033. C
  20034.       DO 45 I2=1,NSORT
  20035.       I3 = BUFFER(I5)
  20036.       I5 = I3 + NSORT
  20037.       I4 = BUFFER(I3) - 1
  20038.       WRITE(OUTFIL) (BUFFER(I3+I4),I3=1,LTUPLE)
  20039.    45 CONTINUE
  20040.       RETURN
  20041.       END
  20042.       SUBROUTINE SWHRTD(NN,LL,BUFFER)
  20043.         Include TEXT.BLK
  20044. C
  20045. C  PURPOSE   TO SORT FIXED OR VARIABLE LENGTH
  20046. C            TUPLES ON ONE OR MORE ATTRIBUTES
  20047. C            INCORE SORT
  20048. C            GENERAL PURPOSE SORT
  20049. C
  20050. C  METHOD    FAST SORTING ALGORITHM PUBLISHED
  20051. C            1978 BY HART
  20052. C            CREATIVE COMPUTING JAN/FEB 1978
  20053. C            P 96 FF
  20054. C
  20055. C  TIMING   .13 CP SEC CYBER 760
  20056. C          1000 TUPLES,1 ATTRIBUTE SORT (INT)
  20057. C
  20058. C  DEFINITION OF VARIABLES
  20059. C
  20060. C  NN       VECTOR OF POINTERS TO BUFFER    (INT,I)
  20061. C
  20062. C  LL       LINK LIST OF POINTERS TO NN     (INT,O)
  20063. C           THE LIST DEFINES THE SORTED ORDER
  20064. C           ORDER OF BUFFER
  20065. C
  20066. C  BUFFER    VECTOR CONTAINING TUPLES TO SORT    (ANY,I)
  20067. C            NN POINTER ARE RELATIVE TO BUFFER(1)
  20068. C
  20069.         Include SRTCOM.BLK
  20070.       INTEGER SWIICP,SWIRCP,SWIDCP,SWITCP
  20071.       DIMENSION NN(1),LL(1)
  20072.       INTEGER BUFFER(1)
  20073.       INTEGER S1
  20074.       K1=0
  20075.       I=0
  20076.       M1=0
  20077.       T2=0.
  20078.       T4=0.
  20079.       J=NSORT+1
  20080.       LL(1)=1
  20081.       LL(J)=1
  20082.       K2=1
  20083.       IF(NSORT.LE.1) RETURN
  20084.       S1=NSORT
  20085.   250 CONTINUE
  20086. C  CLIMB THE TREE
  20087.       IF(S1.LT.4) GO TO 320
  20088.       K2=K2*2
  20089.       B2=S1
  20090.       B2=B2/2.
  20091.       S1=INT(B2)
  20092.       T4=T4+(B2-S1)*K2
  20093.       GO TO 250
  20094.   320 CONTINUE
  20095. C  INITIAL CALCULATIONS
  20096.       T4=K2-T4
  20097.       B2=K2/2
  20098.   350 CONTINUE
  20099. C  NEXT TWIG
  20100.       IF(K1.EQ.K2) RETURN
  20101.       K1=K1+1
  20102.       T1=K1
  20103.       B1=B2
  20104.       T3=T2
  20105.   400 CONTINUE
  20106. C  ADD 1 TO REFLECTED BINARY COUNTER AND CARRY
  20107.       T1=T1/2.
  20108.       IF(INT(T1).LT.T1) GO TO 470
  20109.       M1=M1+1
  20110.       T2=T2-B1
  20111.       B1=B1/2.
  20112.       GO TO 400
  20113.   470 CONTINUE
  20114. C  TWIG CALCULATIONS
  20115.       T2=T2+B1
  20116.       IF(S1.EQ.2) GO TO 550
  20117. C  3-TWIGS AND 4-TWIGS
  20118.       IF(T3.LT.T4) GO TO 560
  20119. C  4-TWIG
  20120.       M1=-M1
  20121.       GO TO 630
  20122.   550 IF(T3.LT.T4) GO TO 610
  20123.   560 CONTINUE
  20124. C  3-TWIG
  20125.       M1=M1+1
  20126.       I=I+1
  20127.       LL(I)=I
  20128.       LL(J)=I
  20129.       J=J+1
  20130.   610 CONTINUE
  20131. C  2-TWIG
  20132.       M1=M1+1
  20133.   630 I=I+1
  20134.       L1=I
  20135.       LL(I)=I
  20136.       LL(J)=I
  20137.       L0=J
  20138.       J=J+1
  20139.       I=I+1
  20140.       L2=I
  20141.       LL(I)=I
  20142.       LL(J)=I
  20143.       GO TO 750
  20144.   700 CONTINUE
  20145. C  MERGE TWIGS AND BRANCHES
  20146.       J=J-1
  20147.       L0=J-1
  20148.       L1=LL(L0)
  20149.       L2=LL(J)
  20150.   750 CONTINUE
  20151.       DO 760 J3=1,NSOVAR
  20152.       JJ3 = VARPOS(J3) - 1
  20153.       NNL1 = NN(L1) + JJ3
  20154.       NNL2 = NN(L2) + JJ3
  20155.       KGOTO = VARTYP(J3)
  20156.       GO TO (751,752,753,754),KGOTO
  20157.   751 J2 = BUFFER(NNL2) - BUFFER(NNL1)
  20158.       GO TO 755
  20159.   752 J2 = SWIRCP(BUFFER(NNL1),BUFFER(NNL2))
  20160.       GO TO 755
  20161.   753 J2 = SWIDCP(BUFFER(NNL1),BUFFER(NNL2))
  20162.       GO TO 755
  20163.   754 J2 = SWITCP(BUFFER(NNL1),BUFFER(NNL2))
  20164.   755 CONTINUE
  20165.       IF(J2 .EQ. 0) GO TO 760
  20166.       IF((J2 .GT. 0 .AND. SORTYP(J3)) .OR.
  20167.      X   (J2 .LT. 0 .AND. .NOT. SORTYP(J3)))
  20168.      XGO TO 820
  20169.       GO TO 765
  20170.   760 CONTINUE
  20171.       GO TO 820
  20172.   765 CONTINUE
  20173.       LL(L0)=L2
  20174.   770 L0=L2
  20175.       L2=LL(L0)
  20176.       IF(L2.EQ.L0) GO TO 870
  20177.       DO 790 J3=1,NSOVAR
  20178.       JJ3 = VARPOS(J3) - 1
  20179.       NNL1 = NN(L1) + JJ3
  20180.       NNL2 = NN(L2) + JJ3
  20181.       KGOTO = VARTYP(J3)
  20182.       GO TO (781,782,783,784),KGOTO
  20183.   781 J2 = BUFFER(NNL2) - BUFFER(NNL1)
  20184.       GO TO 785
  20185.   782 J2 = SWIRCP(BUFFER(NNL1),BUFFER(NNL2))
  20186.       GO TO 785
  20187.   783 J2 = SWIDCP(BUFFER(NNL1),BUFFER(NNL2))
  20188.       GO TO 785
  20189.   784 J2 = SWITCP(BUFFER(NNL1),BUFFER(NNL2))
  20190.   785 CONTINUE
  20191.       IF(J2 .EQ. 0) GO TO 790
  20192.       IF((J2 .GT. 0 .AND. SORTYP(J3)) .OR.
  20193.      X   (J2 .LT. 0 .AND. .NOT. SORTYP(J3)))
  20194.      XGO TO 795
  20195.       GO TO 770
  20196.   790 CONTINUE
  20197.   795 CONTINUE
  20198.       LL(L0)=L1
  20199.   820 L0=L1
  20200.       L1=LL(L0)
  20201.       IF(L1.NE.L0) GO TO 750
  20202.       LL(L0)=L2
  20203.       GO TO 880
  20204.   870 LL(L0)=L1
  20205.   880 M1=M1-1
  20206.       IF(M1.GT.0) GO TO 700
  20207.       IF(M1.EQ.0) GO TO 350
  20208. C  GENERATE 2ND HALF OF A 4-TWIG
  20209.       M1=1-M1
  20210.       GO TO 630
  20211.       END
  20212.       SUBROUTINE SWHRTI(NN,LL,BUFFER)
  20213.         Include TEXT.BLK
  20214. C
  20215. C  PURPOSE   TO SORT FIXED OR VARIABLE LENGTH
  20216. C            TUPLES ON ONE OR MORE ATTRIBUTES
  20217. C            INCORE SORT
  20218. C            FIRST SORT ATTRIBUTE IS INTEGER
  20219. C
  20220. C  METHOD    FAST SORTING ALGORITHM PUBLISHED
  20221. C            1978 BY HART
  20222. C            CREATIVE COMPUTING JAN/FEB 1978
  20223. C            P 96 FF
  20224. C
  20225. C  TIMING   .05 CP SEC CYBER 760
  20226. C          1000 TUPLES,1 ATTRIBUTE SORT (INT)
  20227. C
  20228. C  DEFINITION OF VARIABLES
  20229. C
  20230. C  NN       VECTOR OF POINTERS TO BUFFER    (INT,I)
  20231. C
  20232. C  LL       LINK LIST OF POINTERS TO NN     (INT,O)
  20233. C           THE LIST DEFINES THE SORTED ORDER
  20234. C           ORDER OF BUFFER
  20235. C
  20236. C  BUFFER    VECTOR CONTAINING TUPLES TO SORT    (ANY,I)
  20237. C            NN POINTER ARE RELATIVE TO BUFFER(1)
  20238. C
  20239.         Include SRTCOM.BLK
  20240.       INTEGER SWIICP,SWIRCP,SWIDCP,SWITCP
  20241.       DIMENSION NN(1),LL(1)
  20242.       INTEGER BUFFER(1)
  20243.       INTEGER S1
  20244.       K1=0
  20245.       I=0
  20246.       M1=0
  20247.       T2=0.
  20248.       T4=0.
  20249.       J=NSORT+1
  20250.       LL(1)=1
  20251.       LL(J)=1
  20252.       K2=1
  20253.       IF(NSORT.LE.1) RETURN
  20254.       S1=NSORT
  20255.   250 CONTINUE
  20256. C  CLIMB THE TREE
  20257.       IF(S1.LT.4) GO TO 320
  20258.       K2=K2*2
  20259.       B2=S1
  20260.       B2=B2/2.
  20261.       S1=INT(B2)
  20262.       T4=T4+(B2-S1)*K2
  20263.       GO TO 250
  20264.   320 CONTINUE
  20265. C  INITIAL CALCULATIONS
  20266.       T4=K2-T4
  20267.       B2=K2/2
  20268.   350 CONTINUE
  20269. C  NEXT TWIG
  20270.       IF(K1.EQ.K2) RETURN
  20271.       K1=K1+1
  20272.       T1=K1
  20273.       B1=B2
  20274.       T3=T2
  20275.   400 CONTINUE
  20276. C  ADD 1 TO REFLECTED BINARY COUNTER AND CARRY
  20277.       T1=T1/2.
  20278.       IF(INT(T1).LT.T1) GO TO 470
  20279.       M1=M1+1
  20280.       T2=T2-B1
  20281.       B1=B1/2.
  20282.       GO TO 400
  20283.   470 CONTINUE
  20284. C  TWIG CALCULATIONS
  20285.       T2=T2+B1
  20286.       IF(S1.EQ.2) GO TO 550
  20287. C  3-TWIGS AND 4-TWIGS
  20288.       IF(T3.LT.T4) GO TO 560
  20289. C  4-TWIG
  20290.       M1=-M1
  20291.       GO TO 630
  20292.   550 IF(T3.LT.T4) GO TO 610
  20293.  
  20294.   560 CONTINUE
  20295. C  3-TWIG
  20296.       M1=M1+1
  20297.       I=I+1
  20298.       LL(I)=I
  20299.       LL(J)=I
  20300.       J=J+1
  20301.   610 CONTINUE
  20302. C  2-TWIG
  20303.       M1=M1+1
  20304.   630 I=I+1
  20305.       L1=I
  20306.       LL(I)=I
  20307.       LL(J)=I
  20308.       L0=J
  20309.       J=J+1
  20310.       I=I+1
  20311.       L2=I
  20312.       LL(I)=I
  20313.       LL(J)=I
  20314.       GO TO 750
  20315.   700 CONTINUE
  20316. C  MERGE TWIGS AND BRANCHES
  20317.       J=J-1
  20318.       L0=J-1
  20319.       L1=LL(L0)
  20320.       L2=LL(J)
  20321.   750 CONTINUE
  20322.       NNL2 = NN(L2) + VARPOS(1) - 1
  20323.       NNL1 = NN(L1) + VARPOS(1) - 1
  20324.       J2 = BUFFER(NNL2) - BUFFER(NNL1)
  20325.       IF(J2 .GT. 0 .AND. SORTYP(1)) GO TO 820
  20326.       IF(J2 .LT. 0 .AND. .NOT. SORTYP(1)) GO TO 820
  20327.       IF(J2 .NE. 0) GO TO 765
  20328.       IF(NSOVAR .EQ. 1) GO TO 820
  20329.       DO 760 J3=2,NSOVAR
  20330.       JJ3 = VARPOS(J3) - 1
  20331.       NNL1 = NN(L1) + JJ3
  20332.       NNL2 = NN(L2) + JJ3
  20333.       KGOTO = VARTYP(J3)
  20334.       GO TO (752,753,754,755),KGOTO
  20335.   752 J2 = BUFFER(NNL2) - BUFFER(NNL1)
  20336.       GO TO 756
  20337.   753 J2 = SWIRCP(BUFFER(NNL1),BUFFER(NNL2))
  20338.       GO TO 756
  20339.   754 J2 = SWIDCP(BUFFER(NNL1),BUFFER(NNL2))
  20340.       GO TO 756
  20341.   755 J2 = SWITCP(BUFFER(NNL1),BUFFER(NNL2))
  20342.   756 CONTINUE
  20343.       IF(J2 .EQ. 0) GO TO 760
  20344.       IF((J2 .GT. 0 .AND. SORTYP(J3)) .OR.
  20345.      X   (J2 .LT. 0 .AND. .NOT. SORTYP(J3)))
  20346.      XGO TO 820
  20347.       GO TO 765
  20348.   760 CONTINUE
  20349.       GO TO 820
  20350.   765 CONTINUE
  20351.       LL(L0)=L2
  20352.   770 L0=L2
  20353.       L2=LL(L0)
  20354.       IF(L2.EQ.L0) GO TO 870
  20355.       NNL2 = NN(L2) + VARPOS(1) - 1
  20356.       NNL1 = NN(L1) + VARPOS(1) - 1
  20357.       J2 = BUFFER(NNL2) - BUFFER(NNL1)
  20358.       IF(J2 .GT. 0 .AND. SORTYP(1)) GO TO 795
  20359.       IF(J2 .LT. 0 .AND. .NOT. SORTYP(1)) GO TO 795
  20360.       IF(J2 .NE. 0) GO TO 770
  20361.       IF(NSOVAR .EQ. 1) GO TO 795
  20362.       DO 790 J3=2,NSOVAR
  20363.       JJ3 = VARPOS(J3) - 1
  20364.       NNL1 = NN(L1) + JJ3
  20365.       NNL2 = NN(L2) + JJ3
  20366.       KGOTO = VARTYP(J3)
  20367.       GO TO (781,782,783,784),KGOTO
  20368.   781 J2 = BUFFER(NNL2) - BUFFER(NNL1)
  20369.       GO TO 785
  20370.   782 J2 = SWIRCP(BUFFER(NNL1),BUFFER(NNL2))
  20371.       GO TO 785
  20372.   783 J2 = SWIDCP(BUFFER(NNL1),BUFFER(NNL2))
  20373.       GO TO 785
  20374.   784 J2 = SWITCP(BUFFER(NNL1),BUFFER(NNL2))
  20375.   785 CONTINUE
  20376.       IF(J2 .EQ. 0) GO TO 790
  20377.       IF((J2 .GT. 0 .AND. SORTYP(J3)) .OR.
  20378.      X   (J2 .LT. 0 .AND. .NOT. SORTYP(J3)))
  20379.      XGO TO 795
  20380.       GO TO 770
  20381.   790 CONTINUE
  20382.   795 CONTINUE
  20383.       LL(L0)=L1
  20384.   820 L0=L1
  20385.       L1=LL(L0)
  20386.       IF(L1.NE.L0) GO TO 750
  20387.       LL(L0)=L2
  20388.       GO TO 880
  20389.   870 LL(L0)=L1
  20390.   880 M1=M1-1
  20391.       IF(M1.GT.0) GO TO 700
  20392.       IF(M1.EQ.0) GO TO 350
  20393. C  GENERATE 2ND HALF OF A 4-TWIG
  20394.       M1=1-M1
  20395.       GO TO 630
  20396.       END
  20397.       SUBROUTINE SWHRTR(NN,LL,BUFFER)
  20398.         Include TEXT.BLK
  20399. C
  20400. C  PURPOSE   TO SORT FIXED OR VARIABLE LENGTH
  20401. C            TUPLES ON ONE OR MORE ATTRIBUTES
  20402. C            INCORE SORT
  20403. C             FIRST SORT ATTRIBUTE IS REAL
  20404. C
  20405. C  METHOD    FAST SORTING ALGORITHM PUBLISHED
  20406. C            1978 BY HART
  20407. C            CREATIVE COMPUTING JAN/FEB 1978
  20408. C            P 96 FF
  20409. C
  20410. C  TIMING   .05 CP SEC CYBER 760
  20411. C          1000 TUPLES,1 ATTRIBUTE SORT (REAL)
  20412. C
  20413. C  DEFINITION OF VARIABLES
  20414. C
  20415. C  NN       VECTOR OF POINTERS TO BUFFER    (INT,I)
  20416. C
  20417. C  LL       LINK LIST OF POINTERS TO NN     (INT,O)
  20418. C           THE LIST DEFINES THE SORTED ORDER
  20419. C           ORDER OF BUFFER
  20420. C
  20421. C  BUFFER    VECTOR CONTAINING TUPLES TO SORT    (ANY,I)
  20422. C            NN POINTER ARE RELATIVE TO BUFFER(1)
  20423. C
  20424.         Include SRTCOM.BLK
  20425.       INTEGER SWIICP,SWIRCP,SWIDCP,SWITCP
  20426.       DIMENSION NN(1),LL(1)
  20427.       DIMENSION BUFFER(1)
  20428.       REAL BUFFER
  20429.       INTEGER S1
  20430.       K1=0
  20431.       I=0
  20432.       M1=0
  20433.       T2=0.
  20434.       T4=0.
  20435.       J=NSORT+1
  20436.       LL(1)=1
  20437.       LL(J)=1
  20438.       K2=1
  20439.       IF(NSORT.LE.1) RETURN
  20440.       S1=NSORT
  20441.   250 CONTINUE
  20442. C  CLIMB THE TREE
  20443.       IF(S1.LT.4) GO TO 320
  20444.       K2=K2*2
  20445.       B2=S1
  20446.       B2=B2/2.
  20447.       S1=INT(B2)
  20448.       T4=T4+(B2-S1)*K2
  20449.       GO TO 250
  20450.   320 CONTINUE
  20451. C  INITIAL CALCULATIONS
  20452.       T4=K2-T4
  20453.       B2=K2/2
  20454.   350 CONTINUE
  20455. C  NEXT TWIG
  20456.       IF(K1.EQ.K2) RETURN
  20457.       K1=K1+1
  20458.       T1=K1
  20459.       B1=B2
  20460.       T3=T2
  20461.   400 CONTINUE
  20462. C  ADD 1 TO REFLECTED BINARY COUNTER AND CARRY
  20463.       T1=T1/2.
  20464.       IF(INT(T1).LT.T1) GO TO 470
  20465.       M1=M1+1
  20466.       T2=T2-B1
  20467.       B1=B1/2.
  20468.       GO TO 400
  20469.   470 CONTINUE
  20470. C  TWIG CALCULATIONS
  20471.       T2=T2+B1
  20472.       IF(S1.EQ.2) GO TO 550
  20473. C  3-TWIGS AND 4-TWIGS
  20474.       IF(T3.LT.T4) GO TO 560
  20475. C  4-TWIG
  20476.       M1=-M1
  20477.       GO TO 630
  20478.   550 IF(T3.LT.T4) GO TO 610
  20479.   560 CONTINUE
  20480. C  3-TWIG
  20481.       M1=M1+1
  20482.       I=I+1
  20483.       LL(I)=I
  20484.       LL(J)=I
  20485.       J=J+1
  20486.   610 CONTINUE
  20487. C  2-TWIG
  20488.       M1=M1+1
  20489.   630 I=I+1
  20490.       L1=I
  20491.       LL(I)=I
  20492.       LL(J)=I
  20493.       L0=J
  20494.       J=J+1
  20495.       I=I+1
  20496.       L2=I
  20497.       LL(I)=I
  20498.       LL(J)=I
  20499.       GO TO 750
  20500.   700 CONTINUE
  20501. C  MERGE TWIGS AND BRANCHES
  20502.       J=J-1
  20503.       L0=J-1
  20504.       L1=LL(L0)
  20505.       L2=LL(J)
  20506.   750 CONTINUE
  20507.       JJ3 = VARPOS(1) - 1
  20508.       R2 = BUFFER(NN(L2)+JJ3) - BUFFER(NN(L1)+JJ3)
  20509.       IF(R2 .GT. 0. .AND. SORTYP(1)) GO TO 820
  20510.       IF(R2 .LT. 0. .AND. .NOT. SORTYP(1)) GO TO 820
  20511.       IF(R2 .NE. 0.) GO TO 765
  20512.       IF(NSOVAR .EQ. 1) GO TO 820
  20513.       DO 760 J3=2,NSOVAR
  20514.       JJ3 = VARPOS(J3) - 1
  20515.       NNL1 = NN(L1) + JJ3
  20516.       NNL2 = NN(L2) + JJ3
  20517.       KGOTO = VARTYP(J3)
  20518.       GO TO (752,753,754,755),KGOTO
  20519.   752 J2 = SWIICP(BUFFER(NNL1),BUFFER(NNL2))
  20520.       GO TO 756
  20521.   753 J2 = SWIRCP(BUFFER(NNL1),BUFFER(NNL2))
  20522.       GO TO 756
  20523.   754 J2 = SWIDCP(BUFFER(NNL1),BUFFER(NNL2))
  20524.       GO TO 756
  20525.   755 J2 = SWITCP(BUFFER(NNL1),BUFFER(NNL2))
  20526.   756 CONTINUE
  20527.       IF(J2 .EQ. 0) GO TO 760
  20528.       IF((J2 .GT. 0 .AND. SORTYP(J3)) .OR.
  20529.      X   (J2 .LT. 0 .AND. .NOT. SORTYP(J3)))
  20530.      XGO TO 820
  20531.       GO TO 765
  20532.   760 CONTINUE
  20533.       GO TO 820
  20534.   765 CONTINUE
  20535.       LL(L0)=L2
  20536.   770 L0=L2
  20537.       L2=LL(L0)
  20538.       IF(L2.EQ.L0) GO TO 870
  20539.       JJ3 = VARPOS(1)-1
  20540.       R2 = BUFFER(NN(L2)+JJ3) - BUFFER(NN(L1)+JJ3)
  20541.       IF(R2 .GT. 0. .AND. SORTYP(1)) GO TO 795
  20542.       IF(R2 .LT. 0. .AND. .NOT. SORTYP(1)) GO TO 795
  20543.       IF(R2 .NE. 0.) GO TO 770
  20544.       IF(NSOVAR .EQ. 1) GO TO 795
  20545.       DO 790 J3=2,NSOVAR
  20546.       JJ3 = VARPOS(J3) - 1
  20547.       NNL1 = NN(L1) + JJ3
  20548.       NNL2 = NN(L2) + JJ3
  20549.       KGOTO = VARTYP(J3)
  20550.       GO TO (781,782,783,784),KGOTO
  20551.   781 J2 = SWIICP(BUFFER(NNL1),BUFFER(NNL2))
  20552.       GO TO 785
  20553.   782 J2 = SWIRCP(BUFFER(NNL1),BUFFER(NNL2))
  20554.       GO TO 785
  20555.   783 J2 = SWIDCP(BUFFER(NNL1),BUFFER(NNL2))
  20556.       GO TO 785
  20557.   784 J2 = SWITCP(BUFFER(NNL1),BUFFER(NNL2))
  20558.   785 CONTINUE
  20559.       IF(J2 .EQ. 0) GO TO 790
  20560.       IF((J2 .GT. 0 .AND. SORTYP(J3)) .OR.
  20561.      X   (J2 .LT. 0 .AND. .NOT. SORTYP(J3)))
  20562.      XGO TO 795
  20563.       GO TO 770
  20564.   790 CONTINUE
  20565.   795 CONTINUE
  20566.       LL(L0)=L1
  20567.   820 L0=L1
  20568.       L1=LL(L0)
  20569.       IF(L1.NE.L0) GO TO 750
  20570.       LL(L0)=L2
  20571.       GO TO 880
  20572.   870 LL(L0)=L1
  20573.   880 M1=M1-1
  20574.       IF(M1.GT.0) GO TO 700
  20575.       IF(M1.EQ.0) GO TO 350
  20576. C  GENERATE 2ND HALF OF A 4-TWIG
  20577.       M1=1-M1
  20578.       GO TO 630
  20579.       END
  20580.       SUBROUTINE SWICST(MM,M,N)
  20581.         Include TEXT.BLK
  20582.       DIMENSION M(1),MM(1)
  20583. C
  20584. C
  20585. C  PURPOSE       TO SORT A SUBSET OF EQUIDISTANT
  20586. C                ELEMENTS OF A VECTOR
  20587. C
  20588. C  TIMING        .00015*N*LN(N) SEC
  20589. C
  20590. C  DEFINITION OF PARAMETERS
  20591. C
  20592. C  M         VECTOR OF POINTERS TO MM
  20593. C
  20594. C  MM        VECTOR OF DATA TO SORT
  20595. C
  20596. C  N         NUMBER OF ELEMENTS TO SORT
  20597. C
  20598. C
  20599.         Include SRTCOM.BLK
  20600.       INTEGER SWIICP,SWIRCP,SWIDCP,SWITCP
  20601.       I = 1
  20602.       DO 10 J=1,30
  20603.       IF(I .GE. N) GO TO 20
  20604.    10 I = I * 2
  20605.    20 CONTINUE
  20606.       ID1 = I
  20607.       NN = N
  20608.    50 ID2 = ID1
  20609.       I = I/2
  20610.       IF(I .GT. 0) GO TO 60
  20611.       RETURN
  20612.    60 CONTINUE
  20613.       ID1 = I
  20614.       III = N - I
  20615.       IF(III .GT. I) III = I
  20616.       DO 500 J=1,III
  20617.       I1 = J
  20618.       I2 = I1 + ID1
  20619.       J1 = M(I1)
  20620.       J2 = M(I2)
  20621.   200 CONTINUE
  20622.       DO 220 JJ3=1,NSOVAR
  20623.       JJ4 = VARPOS(JJ3) - 1
  20624.       KGOTO = VARTYP(JJ3)
  20625.       GO TO (211,212,213,214),KGOTO
  20626.   211 JJJ = SWIICP(MM(J1+JJ4),MM(J2+JJ4))
  20627.       GO TO 215
  20628.   212 JJJ = SWIRCP(MM(J1+JJ4),MM(J2+JJ4))
  20629.       GO TO 215
  20630.   213 JJJ = SWIDCP(MM(J1+JJ4),MM(J2+JJ4))
  20631.       GO TO 215
  20632.   214 JJJ = SWITCP(MM(J1+JJ4),MM(J2+JJ4))
  20633.   215 CONTINUE
  20634.       IF(.NOT. SORTYP(JJ3)) JJJ = -JJJ
  20635.       IF(JJJ .GT. 0) GO TO 400
  20636.       IF(JJJ .LT. 0) GO TO 240
  20637.   220 CONTINUE
  20638.       GO TO 400
  20639.   240 CONTINUE
  20640. C
  20641. C  NOT IN SORT
  20642. C
  20643.       M(I1) = J2
  20644.       I1 = I1 + ID1
  20645.       IF(I1 .LT. I2) GO TO 250
  20646. C
  20647. C  JUST FLIP-FLOP
  20648. C
  20649.       M(I2) = J1
  20650.       I2 = I2 + ID2
  20651.       IF(I2 .GT. NN) GO TO 500
  20652.       J2 = M(I2)
  20653.       GO TO 200
  20654. C
  20655. C  MORE THAN ONE TO MOVE DOWN
  20656. C
  20657.   250 JJ = I2 - ID1
  20658.       DO 300 II=I1,JJ,ID1
  20659.       J2 = M(I2 - ID1)
  20660.       M(I2) = J2
  20661.   300 I2 = I2 - ID1
  20662.       I2 = JJ + ID1 + ID2
  20663.       M(I1) = J1
  20664.       IF(I2 .GT. NN) GO TO 500
  20665.       J2 = M(I2)
  20666.       GO TO 200
  20667. C
  20668. C  IN SORT
  20669. C
  20670.   400 I1 = I1 + ID1
  20671.       IF(I1 .LT. I2) GO TO 450
  20672. C
  20673. C  ONE ONLY
  20674. C
  20675.       I2 = I2 + ID1
  20676.       IF(I2 .GT. NN) GO TO 500
  20677.       J1 = J2
  20678.       J2 = M(I2)
  20679.       GO TO 200
  20680. C
  20681. C   MORE THAN ONE
  20682. C
  20683.   450 J1 = M(I1)
  20684.       GO TO 200
  20685.   500 CONTINUE
  20686.       GO TO 50
  20687.       END
  20688.       INTEGER FUNCTION SWIDCP(I1,I2)
  20689.         Include TEXT.BLK
  20690.       DOUBLE PRECISION I1,I2
  20691.       SWIDCP = 1
  20692.       IF(I1 .LT. I2) RETURN
  20693.       IF(I1 .GT. I2) GO TO 10
  20694.       SWIDCP = 0
  20695.       RETURN
  20696.    10 SWIDCP = -1
  20697.       RETURN
  20698.       END
  20699.       INTEGER FUNCTION SWIICP(I1,I2)
  20700.         Include TEXT.BLK
  20701.       SWIICP = 1
  20702.       IF(I1 .LT. I2) RETURN
  20703.       IF(I1 .GT. I2) GO TO 10
  20704.       SWIICP = 0
  20705.       RETURN
  20706.    10 SWIICP = -1
  20707.       RETURN
  20708.       END
  20709.       SUBROUTINE SWINPO(INFIL,OUTFIL,BUFFER,IERR)
  20710.         Include TEXT.BLK
  20711.         Include SRTCOM.BLK
  20712.       DIMENSION BUFFER(1)
  20713.       INTEGER BUFFER,OUTFIL
  20714. C
  20715. C  PURPOSE  CONTROLLING ROUTINE FOR IN-CORE SORT
  20716. C              USING IN-SITU POINTER METHOD
  20717. C
  20718. C
  20719. C  TIMING   UNKNOWN
  20720. C
  20721. C  DEFINITION OF VARIABLES
  20722. C
  20723. C  INFIL   FILE NAME OF FILE (SEQ) WHICH    (INT,I)
  20724. C          CONTAINS INPUT TUPLES
  20725. C         INFIL IS UNFORMATTED (BINARY)
  20726. C         EACH TUPLE IS WRITTEN AS A
  20727. C         RECORD AS FOLLOWS
  20728. C         FOR FIXED LENGTH RECORDS
  20729. C           WRITE(INFIL) (TUP(I),I=1,LTUPLE)
  20730. C         FOR VARIABLE LENGTH RECORDS
  20731. C           WRITE(INFIL) L,(TUP(I),I=1,L)
  20732. C
  20733. C  OUTFIL  FILE NAME OF FILE (SEQ) WHICH    (INT,I)
  20734. C          CONTAINS OUTPUT (SORTED) TUPLES
  20735. C          OUTFIL MAY EQ INFIL
  20736. C          FORMAT OF OUTFIL IS THE
  20737. C          SAME AS THAT OF INFIL
  20738. C
  20739. C  BUFFER  CORE BUFFER TO USE FOR SORT      (ANY,SCR)
  20740. C
  20741. C  IERR    ERROR CONDITION                  (INT,O)
  20742. C           0 NORMAL RETURN
  20743. C           1 ERROR IN FILE READ
  20744. C           2 ERROR IN FILE WRITE
  20745. C
  20746.       I1 = NSORT
  20747.       IF(FIXLT) GO TO 10
  20748. C
  20749. C  INCORE,VAR LENGTH
  20750. C
  20751.       I1 = I1 + 1
  20752.       DO 5 I2=1,NSORT
  20753.       BUFFER(I2) = I1 + 1
  20754.       READ(INFIL) I4,(BUFFER(I1+I5),I5=1,I4)
  20755.       BUFFER(I1) = I4
  20756.     5 I1 = I1 + I4 + 1
  20757.       GO TO 20
  20758.    10 CONTINUE
  20759. C
  20760. C  INCORE,FIXED LENGTH TUPLES
  20761. C
  20762.       DO 15 I2=1,NSORT
  20763.       BUFFER(I2)= I1 + 1
  20764.       READ(INFIL) (BUFFER(I1+I4),I4=1,LTUPLE)
  20765.    15 I1 = I1 + LTUPLE
  20766.    20 CONTINUE
  20767. C
  20768. C  READ COMPLETED,SORT
  20769. C
  20770.       CALL SWICST(BUFFER,BUFFER,NSORT)
  20771. C
  20772. C  SORT COMPLETE,UNLOAD
  20773. C
  20774.       REWIND OUTFIL
  20775.       IF(FIXLT) GO TO 40
  20776. C
  20777. C  VARIABLE LENGTH TUPLES
  20778. C
  20779.       DO 35 I2=1,NSORT
  20780.       I3 = BUFFER(I2) - 1
  20781.       I4 = BUFFER(I3)
  20782.       WRITE(OUTFIL) I4,(BUFFER(I3+I1),I1=1,I4)
  20783.    35 CONTINUE
  20784.       RETURN
  20785.    40 CONTINUE
  20786. C
  20787. C  WRITE FIXED LENGTH TUPLES
  20788. C
  20789.       DO 45 I2=1,NSORT
  20790.       I3 = BUFFER(I2) - 1
  20791.       WRITE(OUTFIL) (BUFFER(I3+I4),I4=1,LTUPLE)
  20792.    45 CONTINUE
  20793.       RETURN
  20794.       END
  20795.       INTEGER FUNCTION SWIRCP(I1,I2)
  20796.         Include TEXT.BLK
  20797.       REAL I1,I2
  20798.       SWIRCP = 1
  20799.       IF(I1 .LT. I2) RETURN
  20800.       IF(I1 .GT. I2) GO TO 10
  20801.       SWIRCP = 0
  20802.       RETURN
  20803.    10 SWIRCP = -1
  20804.       RETURN
  20805.       END
  20806.       INTEGER FUNCTION SWITCP(I1,I2)
  20807.         Include TEXT.BLK
  20808.       CHARACTER*1 W1(4),W2(4)
  20809.       INTEGER IT1,IT2
  20810.       EQUIVALENCE (IT1,W1(1))
  20811.       EQUIVALENCE (IT2,W2(1))
  20812.       IT1 = I1
  20813.       IT2 = I2
  20814.       DO 100 I=1,4
  20815.       IF(W1(I).NE.W2(I)) GO TO 200
  20816.   100 CONTINUE
  20817.       SWITCP = 0
  20818.       RETURN
  20819.   200 CONTINUE
  20820.       IF(W1(I).GT.W2(I)) GO TO 300
  20821.       SWITCP = 1
  20822.       RETURN
  20823.   300 CONTINUE
  20824.       SWITCP = -1
  20825.       RETURN
  20826.       END
  20827.       SUBROUTINE SWSHEL(M,N)
  20828.         Include TEXT.BLK
  20829. C
  20830. C     SORT AN INTEGER ARRAY OF LENGTH N
  20831. C     USING SHELL SORT ALGORITHM
  20832. C
  20833.       DIMENSION M(N)
  20834.       INC = 1
  20835.   100 CONTINUE
  20836.       IF((9*INC+4).GE.N) GO TO 200
  20837.       INC = 3*INC + 1
  20838.       GO TO 100
  20839.   200 CONTINUE
  20840.       IF(INC.LT.1) GO TO 1000
  20841.       NMMINC = N-INC
  20842. C
  20843. C     START THE SORT LOOP
  20844. C
  20845.       DO 800 IS = 1,NMMINC
  20846.       K1 = IS
  20847.       K2 = IS + INC
  20848.       IF(M(K1).LE.M(K2)) GO TO 800
  20849.       MOVE = IS
  20850.       MT = M(K2)
  20851.   400 CONTINUE
  20852.       K1 = MOVE
  20853.       K2 = K1 + INC
  20854.       M(K2) = M(K1)
  20855.       MOVE = MOVE - INC
  20856.       IF(MOVE.LT.1) GO TO 600
  20857.       IF(MT.LT.M(MOVE)) GO TO 400
  20858.   600 CONTINUE
  20859.       M(K1) = MT
  20860.   800 CONTINUE
  20861.       INC = (INC-1)/3
  20862.       GO TO 200
  20863.  1000 CONTINUE
  20864.       RETURN
  20865.       END
  20866.       SUBROUTINE SWSINK(IP,IIP,NIP,BUFFER)
  20867.         Include TEXT.BLK
  20868. C
  20869. C  PURPOSE   TO INSERT A TUPLE INTO A SEQUENCE
  20870. C            OF SORTED TUPLES USING A SINK
  20871. C            SORT.  THE TOP TUPLE IS MOVED DOWN
  20872. C            IN THE EXISTING SEQUENCE UNTIL IT
  20873. C            IS NOT LESS THAN THE NEXT TUPLE
  20874. C            (IF ASCENDING SORT) OR NOT GREATER
  20875. C            THAN THE NEXT TUPLE (DESCENDING SORT)
  20876. C
  20877. C  DEFININITION OF VARIABLES
  20878. C
  20879. C  IP        VECTOR OF INDIRECT POINTERS          (INT,I/O)
  20880. C            IP(I) POINTS TO IIP.
  20881. C            IP(2), ... , IP(NIP) ARE
  20882. C            IN SORT UPON ENTRY. UPON
  20883. C            EXIT IP(1), ... ,IP(NIP)
  20884. C            ARE IN SORT
  20885. C
  20886. C  IIP       VECTOR OF CURRENT POINTERS           (INT,I)
  20887. C            TO BUFFER
  20888. C
  20889. C  NIP       NUMBER OF CURRENT CHAINS             (INT,I)
  20890. C            ** NOTICE **   NIP MUST BE GT 1
  20891. C
  20892. C  BUFFER     VECTOR CONTAINING TUPLES TO SORT    (ANY,I)
  20893. C             IIP POINTERS ARE RELATIVE TO
  20894. C             BUFFER(1)
  20895. C
  20896.         Include SRTCOM.BLK
  20897.       INTEGER SWIICP,SWIRCP,SWIDCP,SWITCP
  20898.       DIMENSION IP(1),IIP(1)
  20899.       DIMENSION BUFFER(1)
  20900.       J1 = IP(1)
  20901.       I1 = IIP(J1)
  20902.       DO 100 I=2,NIP
  20903.       J3 = IP(I)
  20904.       I2 = IIP(J3)
  20905.       DO 20 J4=1,NSOVAR
  20906.       JJ4 = VARPOS(J4) - 1
  20907.       KGOTO = VARTYP(J4)
  20908.       GO TO (11,12,13,14),KGOTO
  20909.    11 J2 = SWIICP(BUFFER(I1+JJ4),BUFFER(I2+JJ4))
  20910.       GO TO 15
  20911.    12 J2 = SWIRCP(BUFFER(I1+JJ4),BUFFER(I2+JJ4))
  20912.       GO TO 15
  20913.    13 J2 = SWIDCP(BUFFER(I1+JJ4),BUFFER(I2+JJ4))
  20914.       GO TO 15
  20915.    14 J2 = SWITCP(BUFFER(I1+JJ4),BUFFER(I2+JJ4))
  20916.    15 CONTINUE
  20917.       IF(J2 .EQ. 0) GO TO 20
  20918.       IF((J2 .GT. 0 .AND. SORTYP(J4)) .OR.
  20919.      X   (J2 .LT. 0 .AND. .NOT. SORTYP(J4)))
  20920.      X    GO TO 200
  20921.       GO TO 30
  20922.    20 CONTINUE
  20923. C
  20924. C    EQUAL,PRESERVE ORIGINAL ORDER
  20925. C
  20926.       IF(J1 .LT. J3) GO TO 200
  20927.    30 CONTINUE
  20928. C
  20929. C     NOT IN SORT, CONTINUE TO SINK
  20930. C
  20931.       IP(I-1) = J3
  20932.       IP(I) = J1
  20933.   100 CONTINUE
  20934.   200 CONTINUE
  20935.       RETURN
  20936.       END
  20937.       SUBROUTINE SWSMFL(BUFFER,CHAIN1,NCHAIN,LCHAIN,OUTREC,OUTCHN,
  20938.      X                   NTUREC,LTUP,LREC,INFIL,OUTFIL)
  20939.         Include TEXT.BLK
  20940. C
  20941. C  PURPOSE   MERGE ONE SET OF CHAINS INTO
  20942. C            SINGLE CHAIN OF SORTED TUPLES
  20943. C
  20944. C  METHOD    A STACK IS ESTABLISHED WITH
  20945. C            CURRENT FIRST TUPLE IN EACH
  20946. C            CHAIN.THE STACK IS IN ORDER.
  20947. C            THE FIRST TUPLE IS REMOVED
  20948. C            FROM THE STACK AND MOVED TO
  20949. C            OUTPUT BUFFER.THE NEXT TUPLE
  20950. C            IN THE PARTICULAR CHAIN IS
  20951. C            (IF ONE EXISTS) PUT ON TOP
  20952. C            OF STACK AND ALLOWED TO
  20953. C            SINK UNTIL IT IS IN SORT.
  20954. C            IF ONE DOES NOT EXIST,THE
  20955. C            STACK IS SHORTENED.WHEN
  20956. C            ONLY ONE CHAIN EXISTS,
  20957. C            ITS TAIL IS MOVED DIRECTLY
  20958. C            TO OUTPUT FILE
  20959. C  DEFINITION OF PARAMETERS
  20960. C
  20961. C  CHAIN1    RECORD NO ON INFILE WHICH CONTAINS   (INT,I)
  20962. C            PAGE 1 OF FIRST CHAIN
  20963. C
  20964. C  NCHAIN   NUMBER OF CHAINS TO MERGE           (INT,I)
  20965. C
  20966. C  LCHAIN    NUMBER OF PAGES PER INPUT CHAIN     (INT,I)
  20967. C
  20968. C  OUTREC    RECORD NO ON OUTFIL OF NEXT RECORD  (INT,I/O)
  20969. C            POSITION - IF ZERO EMPTY OUTPUT FILE - WRITE AT EOI
  20970. C
  20971. C  OUTCHN    OUTPUT CHAIN NUMBER                 (INT,I)
  20972. C
  20973. C  NTUREC     NUMBER OF TUPLES PER FULL PAGE     (INT,I)
  20974. C
  20975. C  LTUP      LENGTH OF A TUPLE                   (INT,I)
  20976. C
  20977. C  INFIL     FET OF INPUT FILE                   (FET,I)
  20978. CC
  20979. C  OUTFILE   FET OF OUTLUT FILE                 (FET,I)
  20980. C
  20981. C  DEFINITION OF LOCAL VARIABLES
  20982. C
  20983. C  IP    IP(I)  CONTAINS POINTER TO IP1
  20984. C               FOR I:TH TUPLE IN STACK
  20985. C  IP1   IP1(I) CONTAINS POINTER TO CURRENT
  20986. C               TUPLE ON PAGE I
  20987. C  IP2   IP2(I) CONTAINS POINTER TO LAST
  20988. C               TUPLE ON PAGE I
  20989. C  IP3   IP3(I) CONTAINS RECORD NUMBER ON
  20990. C               INFILE FOR CURRENT PAGE IN
  20991. C               CHAIN I.NEG IF LAST PAGE IN CHAIN
  20992. C  IP4   IP4(I) CONTAINS POINTER TO FIRST
  20993. C               WORD ON PAGE I
  20994. C
  20995. C  DEFINITION OF LOCAL VARIABLES
  20996. C
  20997. C  I5     NO OF TUPLES ON OUTPUT PAGE
  20998. C  I6     ADDRESS-1 TO NEXT TUPLE ON OUTPUT PAGE
  20999. C  J1      POINTER TO FIRST WORD OF OUTPUT PAGE
  21000. C
  21001.       INTEGER BUFFER(1)
  21002.       INTEGER CHAIN1,OUTREC,OUTCHN,OUTFIL
  21003.       DIMENSION IP(10),IP1(10),IP2(10),IP3(10),IP4(10)
  21004. C
  21005. C  INITIALIZE,IE LOAD THE FIRST
  21006. C  BLOCKS OF THE INPUT CHAINS,SET
  21007. C  UP CONTROL ARRAYS IP,IP1,...,IP4
  21008. C
  21009.       J1 = NCHAIN*LREC + 1
  21010.       BUFFER(J1) = NTUREC
  21011.       BUFFER(J1+1) = OUTCHN
  21012.       I1 = CHAIN1
  21013.       I2 = 1
  21014.       DO 10 I=1,NCHAIN
  21015. C* READ RECORD I1 TO BUFFER I2,LENGTH= LREC
  21016.       CALL RIOIN(INFIL,I1,BUFFER(I2),LREC,IOS)
  21017.       IP1(I) = I2+2
  21018.       IP2(I) = I2+(BUFFER(I2)-1)*LTUP+2
  21019.       IP3(I) = I1
  21020.       IF(BUFFER(I2+1) .LT. 0) IP3(I) = -IP3(I)
  21021.       IP(I) = I
  21022.       IP4(I) = I2
  21023.       I1 = I1 + LCHAIN
  21024.       I2 = I2 + LREC
  21025.    10 CONTINUE
  21026.       IF(NCHAIN .GT. 1) GO TO 17
  21027.       I1 = 1
  21028.       J1 = 1
  21029.       GO TO 123
  21030.    17 CONTINUE
  21031.       DO 15 I=2,NCHAIN
  21032.       CALL SWSINK(IP(NCHAIN-I+1),IP1(1),I,BUFFER)
  21033.    15 CONTINUE
  21034.       NIP = NCHAIN
  21035. C
  21036. C  INITIAL SETUP COMPLETE,
  21037. C  PREPARE FOR MERGE CYCLE
  21038. C
  21039.    20 CONTINUE
  21040.       I5 = 0
  21041.       I6 = J1 + 1
  21042. C
  21043. C  I5 IS NO TUPLES IN OUTPUT PAGE
  21044. C  I6 IS ADDRESS-1 TO NEXT TUPLE
  21045. C        ON OUTPUT PAGE
  21046. C
  21047.    25 CONTINUE
  21048.       IF(I5 .LT. NTUREC) GO TO 27
  21049. C
  21050. C  OUTPUT PAGE FULL
  21051. C
  21052. C* WRITE OUTPUT BUFFER TO OUTFILE,RECORD OUTREC
  21053.       CALL RIOOUT(OUTFIL,OUTREC,BUFFER(J1),LREC,IOS)
  21054.       IF(OUTREC.NE.0) OUTREC = OUTREC + 1
  21055.       GO TO 20
  21056.    27 I1 = IP(1)
  21057.       I2 = IP1(I1) - 1
  21058.       DO 30 I=1,LTUP
  21059.    30 BUFFER(I6+I) = BUFFER(I2+I)
  21060.       I5 = I5+1
  21061.       I6 = I6 + LTUP
  21062.       IP1(I1) = IP1(I1) + LTUP
  21063.       IF(IP1(I1) .LE. IP2(I1)) GO TO 50
  21064. C
  21065. C  INPUT BLOCK EMPTY
  21066. C
  21067.       IF(IP3(I1) .LT. 0) GO TO 40
  21068.       I2 = IP4(I1)
  21069. C*  READ BLOCK IP3(I1) TO BUFFER(I2)
  21070.       IP3(I1) = IP3(I1) + 1
  21071.       CALL RIOIN(INFIL,IP3(I1),BUFFER(I2),LREC,IOS)
  21072.       IP1(I1) =I2+2
  21073.       IP2(I1) = I2 + (BUFFER(I2)-1)*LTUP + 2
  21074.       IF(BUFFER(I2+1) .LT. 0) IP3(I1) = -IP3(I1)
  21075.       GO TO 50
  21076.    40 CONTINUE
  21077. C
  21078. C  CURRENT PAGE IS LAST PAGE IN CHAIN
  21079. C
  21080.       DO 45 I=2,NIP
  21081.    45 IP(I-1) = IP(I)
  21082.       NIP = NIP - 1
  21083.       IF(NIP .EQ. 1) GO TO 100
  21084.       GO TO 25
  21085.    50 CONTINUE
  21086. C
  21087. C  CURRENT IP(1) TUPLE MOVED
  21088. C  PICK UP NEXT AND LET IT SINK
  21089. C
  21090.       CALL SWSINK(IP,IP1,NIP,BUFFER)
  21091.       GO TO 25
  21092.   100 CONTINUE
  21093. C
  21094. C  ONLY ONE INPUT CHAIN LEFT
  21095. C
  21096.       I1 = IP(1)
  21097.       IF(I5 .LT. NTUREC) GO TO 103
  21098.       CALL RIOOUT(OUTFIL,OUTREC,BUFFER(J1),LREC,IOS)
  21099.       IF(OUTREC .NE. 0) OUTREC = OUTREC + 1
  21100.       J1 = IP4(I1)
  21101.       GO TO 123
  21102.   103 CONTINUE
  21103.       I2 = IP1(I1) - 1
  21104.       GO TO 115
  21105.   105 CONTINUE
  21106.       DO 110 I=1,LTUP
  21107.   110 BUFFER(I6+I) = BUFFER(I2+I)
  21108.       I6 = I6 + LTUP
  21109.       I2 = I2 + LTUP
  21110.       I5 = I5 + 1
  21111.   115 IF(I2 .LT. IP2(I1)) GO TO 105
  21112.       BUFFER(J1) = I5
  21113.       IF(IP3(I1) .LT. 0) BUFFER(J1+1) = -BUFFER(J1+1)
  21114. C* WRITE OUTPUT BUFFER
  21115.       CALL RIOOUT(OUTFIL,OUTREC,BUFFER(J1),LREC,IOS)
  21116.       IF(OUTREC.NE.0) OUTREC = OUTREC + 1
  21117.       IF(IP3(I1) .LT. 0) RETURN
  21118.   120 CONTINUE
  21119. C* READ RECORD IP3(I1) TO OUTPUT RECORD
  21120.       IP3(I1) = IP3(I1) + 1
  21121.       CALL RIOIN(INFIL,IP3(I1),BUFFER(J1),LREC,IOS)
  21122.   123 CONTINUE
  21123.       IF(BUFFER(J1+1) .LT. 0) GO TO 125
  21124.       BUFFER(J1+1) = OUTCHN
  21125. C* WRITE OUTPUT BUFFER
  21126.       CALL RIOOUT(OUTFIL,OUTREC,BUFFER(J1),LREC,IOS)
  21127.       IF(OUTREC.NE.0) OUTREC = OUTREC + 1
  21128.       GO TO 120
  21129.   125 CONTINUE
  21130.       BUFFER(J1+1) = -OUTCHN
  21131. C* WRITE OUTPUT BUFFER
  21132.       CALL RIOOUT(OUTFIL,OUTREC,BUFFER(J1),LREC,IOS)
  21133.       IF(OUTREC.NE.0) OUTREC = OUTREC + 1
  21134.       RETURN
  21135.       END
  21136.       SUBROUTINE SWSMVL(BUFFER,CHAIN1,NCHAIN,LCHAIN,OUTREC,OUTCHN,
  21137.      X                   INCH1,LREC,INFIL,OUTFIL)
  21138.         Include TEXT.BLK
  21139. C
  21140. C  PURPOSE   MERGE ONE SET OF CHAINS INTO
  21141. C            SINGLE CHAIN OF SORTED TUPLES
  21142. C
  21143. C  METHOD    A STACK IS ESTABLISHED WITH
  21144. C            CURRENT FIRST TUPLE IN EACH
  21145. C            CHAIN.THE STACK IS IN ORDER.
  21146. C            THE FIRST TUPLE IS REMOVED
  21147. C            FROM THE STACK AND MOVED TO
  21148. C            OUTPUT BUFFER.THE NEXT TUPLE
  21149. C            IN THE PARTICULAR CHAIN IS
  21150. C            (IF ONE EXISTS) PUT ON TOP
  21151. C            OF STACK AND ALLOWED TO
  21152. C            SINK UNTIL IT IS IN SORT.
  21153. C            IF ONE DOES NOT EXIST,THE
  21154. C            STACK IS SHORTENED.WHEN
  21155. C            ONLY ONE CHAIN EXISTS,
  21156. C            ITS TAIL IS MOVED DIRECTLY
  21157. C            TO OUTPUT FILE
  21158. C  DEFINITION OF PARAMETERS
  21159. C
  21160. C  CHAIN1    RECORD NO ON INFILE WHICH CONTAINS   (INT,I)
  21161. C            PAGE 1 OF FIRST CHAIN
  21162. C
  21163. C  NCHAIN   NUMBER OF CHAINS TO MERGE           (INT,I)
  21164. C
  21165. C  LCHAIN    NUMBER OF PAGES PER INPUT CHAIN     (INT,I)
  21166. C
  21167. C  OUTREC    RECORD NO ON OUTFIL OF NEXT RECORD  (INT,I/O)
  21168. C            POSITION - IF ZERO EMPTY OUTPUT FILE - WRITE AT EOI
  21169. C
  21170. C  OUTCHN    OUTPUT CHAIN NUMBER                 (INT,I)
  21171. C
  21172. C  INCH1     CHAIN NUMBER OF FIRST INPUT CHAIN   (INT,I)
  21173. C
  21174. C  INFIL     FET OF INPUT FILE                   (FET,I)
  21175. CC
  21176. C  OUTFILE   FET OF OUTLUT FILE                 (FET,I)
  21177. C
  21178. C  DEFINITION OF LOCAL VARIABLES
  21179. C
  21180. C  IP    IP(I)  CONTAINS POINTER TO IP1
  21181. C               FOR I:TH TUPLE IN STACK
  21182. C  IP1   IP1(I) CONTAINS POINTER TO CURRENT
  21183. C               TUPLE ON PAGE I
  21184. C  IP2   IP2(I) CONTAINS NUMBER OF TUPLES
  21185. C               ON PAGE I
  21186. C  IP3   IP3(I) CONTAINS RECORD NUMBER ON
  21187. C               INFILE FOR CURRENT PAGE IN
  21188. C               CHAIN I.NEG IF LAST PAGE IN CHAIN
  21189. C  IP4   IP4(I) CONTAINS POINTER TO FIRST
  21190. C               WORD ON PAGE I
  21191. C
  21192. C  IP5   IP5(I) CONTAINS SEQUENTIAL TUPLE NUMBER
  21193. C                OF CURRENT TUPLE PAGE I.
  21194.  
  21195. C
  21196. C  DEFINITION OF LOCAL VARIABLES
  21197. C
  21198. C  I5     NO OF TUPLES ON OUTPUT PAGE
  21199. C  I6     ADDRESS-1 TO NEXT TUPLE ON OUTPUT PAGE
  21200. C  J1      POINTER TO FIRST WORD OF OUTPUT PAGE
  21201. C  INCH    INPUT CHAIN NUMBER
  21202. C  OUCH    OUTPUT RECORD NUMBER IN CHAIN
  21203. C
  21204.       INTEGER BUFFER(1)
  21205.       INTEGER CHAIN1,OUTREC,OUTCHN,OUTFIL
  21206.       DIMENSION IP(10),IP1(10),IP2(10),IP3(10),IP4(10)
  21207.       DIMENSION IP5(10)
  21208.       INTEGER OUCH
  21209. C
  21210. C  INITIALIZE,IE LOAD THE FIRST
  21211. C  BLOCKS OF THE INPUT CHAINS,SET
  21212. C  UP CONTROL ARRAYS IP,IP1,...,IP4
  21213. C
  21214.       J1 = NCHAIN*LREC + 1
  21215.       J2 = J1 + LREC - 1
  21216.       BUFFER(J1+1) = OUTCHN
  21217.       I1 = CHAIN1
  21218.       I2 = 1
  21219.       OUCH = 1
  21220.       INCH = INCH1
  21221.       DO 10 I=1,NCHAIN
  21222. C* READ RECORD I1 TO BUFFER I2,LENGTH= LREC
  21223.     1 CONTINUE
  21224. C
  21225. C     LOOK FOR CORRECT RECORD
  21226. C
  21227.       CALL RIOIN(INFIL,I1,BUFFER(I2),LREC,IOS)
  21228.       NUMCH = IABS(BUFFER(I2+1))
  21229.       IF(NUMCH.LT.INCH) GO TO 5
  21230.       IF(NUMCH.GT.INCH) GO TO 7
  21231. C
  21232. C     WE ARE IN THE CORRECT CHAIN
  21233. C
  21234.       INT = BUFFER(I2+2)
  21235.       IF(INT.EQ.1) GO TO 8
  21236.       I1 = I1 - INT + 1
  21237.       GO TO 1
  21238.     5 CONTINUE
  21239. C
  21240. C     IN SOME PREVIOUS CHAIN
  21241. C
  21242.       I1 = I1 + 1
  21243.       IF(BUFFER(I2+1).GT.0) I1 = I1 + 1
  21244.       GO TO 1
  21245.     7 CONTINUE
  21246. C
  21247. C     GOOD LORD - IN SOME SUBSEQUENT CHAIN
  21248. C
  21249.       I1 = I1 - BUFFER(I2+2)
  21250.       GO TO 1
  21251.     8 CONTINUE
  21252. C
  21253. C     FOUND THE FIRST RECORD IN CHAIN INCH
  21254. C
  21255.       IP1(I) = I2+4
  21256.       IP2(I) = BUFFER(I2)
  21257.       IP5(I) = 1
  21258.       IP3(I) = I1
  21259.       IF(BUFFER(I2+1) .LT. 0) IP3(I) = -IP3(I)
  21260.       IP(I) = I
  21261.       IP4(I) = I2
  21262.       I1 = I1 + LCHAIN
  21263.       I2 = I2 + LREC
  21264.       INCH = INCH + 1
  21265.    10 CONTINUE
  21266.       IF(NCHAIN.EQ.1) GO TO 18
  21267.       DO 15 I=2,NCHAIN
  21268.       CALL SWSINK(IP(NCHAIN-I+1),IP1(1),I,BUFFER)
  21269.    15 CONTINUE
  21270.    18 CONTINUE
  21271.       NIP = NCHAIN
  21272. C
  21273. C  INITIAL SETUP COMPLETE,
  21274. C  PREPARE FOR MERGE CYCLE
  21275. C
  21276.    20 CONTINUE
  21277.       I5 = 0
  21278.       I6 = J1 + 2
  21279. C
  21280. C  I5 IS NO TUPLES IN OUTPUT PAGE
  21281. C  I6 IS ADDRESS-1 TO NEXT TUPLE
  21282. C        ON OUTPUT PAGE
  21283. C
  21284.    25 CONTINUE
  21285.       I1 = IP(1)
  21286.       I2 = IP1(I1) - 2
  21287.       LTUP = BUFFER(I2+1) + 1
  21288.       IF((I6+LTUP).LE.J2) GO TO 27
  21289. C
  21290. C  OUTPUT PAGE FULL
  21291. C
  21292. C* WRITE OUTPUT BUFFER TO OUTFILE,RECORD OUTREC
  21293.       BUFFER(J1) = I5
  21294.       BUFFER(J1+2) = OUCH
  21295.       CALL RIOOUT(OUTFIL,OUTREC,BUFFER(J1),LREC,IOS)
  21296.       OUCH = OUCH + 1
  21297.       IF(OUTREC.NE.0) OUTREC = OUTREC + 1
  21298.       GO TO 20
  21299.    27 CONTINUE
  21300.       DO 30 I=1,LTUP
  21301.    30 BUFFER(I6+I) = BUFFER(I2+I)
  21302.       I5 = I5+1
  21303.       I6 = I6 + LTUP
  21304.       IP1(I1) = IP1(I1) + LTUP
  21305.       IP5(I1) = IP5(I1) + 1
  21306.       IF(IP5(I1) .LE. IP2(I1)) GO TO 50
  21307. C
  21308. C  INPUT BLOCK EMPTY
  21309. C
  21310.       IF(IP3(I1) .LT. 0) GO TO 40
  21311.       I2 = IP4(I1)
  21312. C*  READ BLOCK IP3(I1) TO BUFFER(I2)
  21313.       IP3(I1) = IP3(I1) + 1
  21314.       CALL RIOIN(INFIL,IP3(I1),BUFFER(I2),LREC,IOS)
  21315.       IP1(I1) =I2 + 4
  21316.       IP2(I1) = BUFFER(I2)
  21317.       IP5(I1) = 1
  21318.       IF(BUFFER(I2+1) .LT. 0) IP3(I1) = -IP3(I1)
  21319.       GO TO 50
  21320.    40 CONTINUE
  21321. C
  21322. C  CURRENT PAGE IS LAST PAGE IN CHAIN
  21323. C
  21324.       IF(NIP.EQ.1) GO TO 100
  21325.       DO 45 I=2,NIP
  21326.    45 IP(I-1) = IP(I)
  21327.       NIP = NIP - 1
  21328.       GO TO 25
  21329.    50 CONTINUE
  21330. C
  21331. C  CURRENT IP(1) TUPLE MOVED
  21332. C  PICK UP NEXT AND LET IT SINK
  21333. C
  21334.       IF(NIP.GT.1) CALL SWSINK(IP,IP1,NIP,BUFFER)
  21335.       GO TO 25
  21336.   100 CONTINUE
  21337. C
  21338. C     ALL DONE
  21339. C
  21340.       IF(I5.EQ.0) RETURN
  21341.       BUFFER(J1) = I5
  21342.       BUFFER(J1+2) = OUCH
  21343.       BUFFER(J1+1) = -OUTCHN
  21344. C* WRITE OUTPUT BUFFER
  21345.       CALL RIOOUT(OUTFIL,OUTREC,BUFFER(J1),LREC,IOS)
  21346.       IF(OUTREC.NE.0) OUTREC = OUTREC + 1
  21347.       RETURN
  21348.       END
  21349.       SUBROUTINE SWUNLO(BUFFER,CHAIN1,NCHAIN,LCHAIN,
  21350.      X                   LTUP,LREC,INFIL,OUTFIL)
  21351.         Include TEXT.BLK
  21352. C
  21353. C  PURPOSE   MERGE ONE SET OF CHAINS INTO
  21354. C            SINGLE CHAIN OF SORTED TUPLES
  21355. C
  21356. C  METHOD    A STACK IS ESTABLISHED WITH
  21357. C            CURRENT FIRST TUPLE IN EACH
  21358. C            CHAIN.THE STACK IS IN ORDER.
  21359. C            THE FIRST TUPLE IS REMOVED
  21360. C            FROM THE STACK AND MOVED TO
  21361. C            OUTPUT BUFFER.THE NEXT TUPLE
  21362. C            IN THE PARTICULAR CHAIN IS
  21363. C            (IF ONE EXISTS) PUT ON TOP
  21364. C            OF STACK AND ALLOWED TO
  21365. C            SINK UNTIL IT IS IN SORT.
  21366. C            IF ONE DOES NOT EXIST,THE
  21367. C            STACK IS SHORTENED.WHEN
  21368. C            ONLY ONE CHAIN EXISTS,
  21369. C            ITS TAIL IS MOVED DIRECTLY
  21370. C            TO OUTPUT FILE
  21371. C  DEFINITION OF PARAMETERS
  21372. C
  21373. C  CHAIN1    RECORD NO ON INFILE WHICH CONTAINS   (INT,I)
  21374. C            PAGE 1 OF FIRST CHAIN
  21375. C
  21376. C  NCHAIN   NUMBER OF CHAINS TO MERGE           (INT,I)
  21377. C
  21378. C  LCHAIN    NUMBER OF PAGES PER INPUT CHAIN     (INT,I)
  21379. C
  21380. C
  21381. C  LTUP      LENGTH OF A TUPLE                   (INT,I)
  21382. C
  21383. C  INFIL     FET OF INPUT FILE                   (FET,I)
  21384. CC
  21385. C  OUTFILE   FET OF OUTLUT FILE                 (FET,I)
  21386. C
  21387. C  DEFINITION OF LOCAL VARIABLES
  21388. C
  21389. C  IP    IP(I)  CONTAINS POINTER TO IP1
  21390. C               FOR I:TH TUPLE IN STACK
  21391. C  IP1   IP1(I) CONTAINS POINTER TO CURRENT
  21392. C               TUPLE ON PAGE I
  21393. C  IP2   IP2(I) CONTAINS POINTER TO LAST
  21394. C               TUPLE ON PAGE I
  21395. C  IP3   IP3(I) CONTAINS RECORD NUMBER ON
  21396. C               INFILE FOR CURRENT PAGE IN
  21397. C               CHAIN I.NEG IF LAST PAGE IN CHAIN
  21398. C  IP4   IP4(I) CONTAINS POINTER TO FIRST
  21399. C               WORD ON PAGE I
  21400. C
  21401.       INTEGER BUFFER(1)
  21402.       INTEGER CHAIN1
  21403.       INTEGER OUTFIL
  21404.       DIMENSION IP(10),IP1(10),IP2(10),IP3(10),IP4(10)
  21405. C
  21406. C  INITIALIZE,IE LOAD THE FIRST
  21407. C  BLOCKS OF THE INPUT CHAINS,SET
  21408. C  UP CONTROL ARRAYS IP,IP1,...,IP4
  21409. C
  21410.       REWIND OUTFIL
  21411.       I1 = CHAIN1
  21412.       I2 = 1
  21413.       DO 10 I=1,NCHAIN
  21414. C* READ RECORD I1 TO BUFFER I2,LENGTH= LREC
  21415.       CALL RIOIN(INFIL,I1,BUFFER(I2),LREC,IOS)
  21416.       IP1(I) = I2+2
  21417.       IP2(I) = I2+(BUFFER(I2)-1)*LTUP+2
  21418.       IP3(I) = I1
  21419.       IF(BUFFER(I2+1) .LT. 0) IP3(I) = -IP3(I)
  21420.       IP(I) = I
  21421.       IP4(I) = I2
  21422.       I1 = I1 + LCHAIN
  21423.       I2 = I2 + LREC
  21424.    10 CONTINUE
  21425.       IF(NCHAIN .GT. 1) GO TO 17
  21426.       IP3(1) = CHAIN1 - 1
  21427.       I1 = 1
  21428.       GO TO 120
  21429.    17 CONTINUE
  21430.       DO 15 I=2,NCHAIN
  21431.       CALL SWSINK(IP(NCHAIN-I+1),IP1(1),I,BUFFER)
  21432.    15 CONTINUE
  21433.       NIP = NCHAIN
  21434. C
  21435. C  INITIAL SETUP COMPLETE,
  21436. C  PREPARE FOR MERGE CYCLE
  21437. C
  21438.    20 CONTINUE
  21439.    25 CONTINUE
  21440.       I1 = IP(1)
  21441.       I2 = IP1(I1) - 1
  21442.       WRITE(OUTFIL) (BUFFER(I2+I),I=1,LTUP)
  21443.       IP1(I1) = IP1(I1) + LTUP
  21444.       IF(IP1(I1) .LE. IP2(I1)) GO TO 50
  21445. C
  21446. C  INPUT BLOCK EMPTY
  21447. C
  21448.       IF(IP3(I1) .LT. 0) GO TO 40
  21449.       I2 = IP4(I1)
  21450. C*  READ BLOCK IP3(I1) TO BUFFER(I2)
  21451.       IP3(I1) = IP3(I1) + 1
  21452.       CALL RIOIN(INFIL,IP3(I1),BUFFER(I2),LREC,IOS)
  21453.       IP1(I1) =I2+2
  21454.       IP2(I1) = I2 + (BUFFER(I2)-1)*LTUP + 2
  21455.       IF(BUFFER(I2+1) .LT. 0) IP3(I1) = -IP3(I1)
  21456.       GO TO 50
  21457.    40 CONTINUE
  21458. C
  21459. C  CURRENT PAGE IS LAST PAGE IN CHAIN
  21460. C
  21461.       DO 45 I=2,NIP
  21462.    45 IP(I-1) = IP(I)
  21463.       NIP = NIP - 1
  21464.       IF(NIP .EQ. 1) GO TO 100
  21465.       GO TO 25
  21466.    50 CONTINUE
  21467. C
  21468. C  CURRENT IP(1) TUPLE MOVED
  21469. C  PICK UP NEXT AND LET IT SINK
  21470. C
  21471.       CALL SWSINK(IP,IP1,NIP,BUFFER)
  21472.       GO TO 25
  21473.   100 CONTINUE
  21474. C
  21475. C  ONLY ONE INPUT CHAIN LEFT
  21476. C
  21477.       I1 = IP(1)
  21478.       I2 = IP1(I1) - 1
  21479.       GO TO 115
  21480.   105 CONTINUE
  21481.       WRITE(OUTFIL) (BUFFER(I2+I),I=1,LTUP)
  21482.       I2 = I2 + LTUP
  21483.   115 IF(I2 .LT. IP2(I1)) GO TO 105
  21484.       IF(IP3(I1) .LT. 0) RETURN
  21485.   120 CONTINUE
  21486. C* READ RECORD IP3(I1)
  21487.       I2 = IP4(I1)
  21488.       IP3(I1) = IP3(I1) + 1
  21489.       CALL RIOIN(INFIL,IP3(I1),BUFFER(I2),LREC,IOS)
  21490.       IP1(I1) = I2 + 2
  21491.       IP2(I1) = I2 + (BUFFER(I2)-1)*LTUP +2
  21492.       IF(BUFFER(I2+1) .LT. 0) IP3(I1) = -IP3(I1)
  21493.       GO TO 100
  21494.       END
  21495.       SUBROUTINE SWUNVL(BUFFER,CHAIN1,NCHAIN,LCHAIN,
  21496.      X                   INCH1,LREC,INFIL,OUTFIL)
  21497.         Include TEXT.BLK
  21498. C
  21499. C  PURPOSE   MERGE ONE SET OF CHAINS INTO
  21500. C            SINGLE CHAIN OF SORTED TUPLES
  21501. C
  21502. C  METHOD    A STACK IS ESTABLISHED WITH
  21503. C            CURRENT FIRST TUPLE IN EACH
  21504. C            CHAIN.THE STACK IS IN ORDER.
  21505. C            THE FIRST TUPLE IS REMOVED
  21506. C            FROM THE STACK AND MOVED TO
  21507. C            OUTPUT BUFFER.THE NEXT TUPLE
  21508. C            IN THE PARTICULAR CHAIN IS
  21509. C            (IF ONE EXISTS) PUT ON TOP
  21510. C            OF STACK AND ALLOWED TO
  21511. C            SINK UNTIL IT IS IN SORT.
  21512. C            IF ONE DOES NOT EXIST,THE
  21513. C            STACK IS SHORTENED.WHEN
  21514. C            ONLY ONE CHAIN EXISTS,
  21515. C            ITS TAIL IS MOVED DIRECTLY
  21516. C            TO OUTPUT FILE
  21517. C  DEFINITION OF PARAMETERS
  21518. C
  21519. C  CHAIN1    RECORD NO ON INFILE WHICH CONTAINS   (INT,I)
  21520. C            PAGE 1 OF FIRST CHAIN
  21521. C
  21522. C  NCHAIN   NUMBER OF CHAINS TO MERGE           (INT,I)
  21523. C
  21524. C  LCHAIN    NUMBER OF PAGES PER INPUT CHAIN     (INT,I)
  21525. C
  21526. C  INCH1     CHAIN NUMBER OF FIRST INPUT CHAIN   (INT,I)
  21527. C
  21528. C  INFIL     FET OF INPUT FILE                   (FET,I)
  21529. CC
  21530. C  OUTFILE   FET OF OUTLUT FILE                 (FET,I)
  21531. C
  21532. C  DEFINITION OF LOCAL VARIABLES
  21533. C
  21534. C  IP    IP(I)  CONTAINS POINTER TO IP1
  21535. C               FOR I:TH TUPLE IN STACK
  21536. C  IP1   IP1(I) CONTAINS POINTER TO CURRENT
  21537. C               TUPLE ON PAGE I
  21538. C  IP2   IP2(I) CONTAINS NUMBER OF TUPLES
  21539. C               ON PAGE I
  21540. C  IP3   IP3(I) CONTAINS RECORD NUMBER ON
  21541. C               INFILE FOR CURRENT PAGE IN
  21542. C               CHAIN I.NEG IF LAST PAGE IN CHAIN
  21543. C  IP4   IP4(I) CONTAINS POINTER TO FIRST
  21544. C               WORD ON PAGE I
  21545. C
  21546. C  IP5   IP5(I) CONTAINS SEQUENTIAL TUPLE NUMBER
  21547. C                OF CURRENT TUPLE PAGE I.
  21548. C
  21549. C  DEFINITION OF LOCAL VARIABLES
  21550. C
  21551. C  INCH    INPUT CHAIN NUMBER
  21552. C
  21553.       INTEGER BUFFER(1)
  21554.       INTEGER CHAIN1
  21555.       INTEGER OUTFIL
  21556.       DIMENSION IP(10),IP1(10),IP2(10),IP3(10),IP4(10)
  21557.       DIMENSION IP5(10)
  21558. C
  21559. C  INITIALIZE,IE LOAD THE FIRST
  21560. C  BLOCKS OF THE INPUT CHAINS,SET
  21561. C  UP CONTROL ARRAYS IP,IP1,...,IP4
  21562. C
  21563.       REWIND OUTFIL
  21564.       I1 = CHAIN1
  21565.       I2 = 1
  21566.       INCH = INCH1
  21567.       DO 10 I=1,NCHAIN
  21568. C* READ RECORD I1 TO BUFFER I2,LENGTH= LREC
  21569.     1 CONTINUE
  21570. C
  21571. C     LOOK FOR CORRECT RECORD
  21572. C
  21573.       CALL RIOIN(INFIL,I1,BUFFER(I2),LREC,IOS)
  21574.       NUMCH = IABS(BUFFER(I2+1))
  21575.       IF(NUMCH.LT.INCH) GO TO 5
  21576.       IF(NUMCH.GT.INCH) GO TO 7
  21577. C
  21578. C     WE ARE IN THE CORRECT CHAIN
  21579. C
  21580.       INT = BUFFER(I2+2)
  21581.       IF(INT.EQ.1) GO TO 8
  21582.       I1 = I1 - INT + 1
  21583.       GO TO 1
  21584.     5 CONTINUE
  21585. C
  21586. C     IN SOME PREVIOUS CHAIN
  21587. C
  21588.       I1 = I1 + 1
  21589.       IF(BUFFER(I2+1).GT.0) I1 = I1 + 1
  21590.       GO TO 1
  21591.     7 CONTINUE
  21592. C
  21593. C     GOOD LORD - IN SOME SUBSEQUENT CHAIN
  21594. C
  21595.       I1 = I1 - BUFFER(I2+2)
  21596.       GO TO 1
  21597.     8 CONTINUE
  21598. C
  21599. C     FOUND THE FIRST RECORD IN CHAIN INCH
  21600. C
  21601.       IP1(I) = I2+4
  21602.       IP2(I) = BUFFER(I2)
  21603.       IP5(I) = 1
  21604.       IP3(I) = I1
  21605.       IF(BUFFER(I2+1) .LT. 0) IP3(I) = -IP3(I)
  21606.       IP(I) = I
  21607.       IP4(I) = I2
  21608.       I1 = I1 + LCHAIN
  21609.       I2 = I2 + LREC
  21610.       INCH = INCH + 1
  21611.    10 CONTINUE
  21612.       IF(NCHAIN.EQ.1) GO TO 18
  21613.       DO 15 I=2,NCHAIN
  21614.       CALL SWSINK(IP(NCHAIN-I+1),IP1(1),I,BUFFER)
  21615.    15 CONTINUE
  21616.    18 CONTINUE
  21617.       NIP = NCHAIN
  21618. C
  21619. C  INITIAL SETUP COMPLETE,
  21620. C  PREPARE FOR MERGE CYCLE
  21621. C
  21622.    25 CONTINUE
  21623.       I1 = IP(1)
  21624.       I2 = IP1(I1) - 2
  21625.       LTUP = BUFFER(I2+1) + 1
  21626.    27 CONTINUE
  21627.       WRITE(OUTFIL) (BUFFER(I+I2),I=1,LTUP)
  21628.       IP1(I1) = IP1(I1) + LTUP
  21629.       IP5(I1) = IP5(I1) + 1
  21630.       IF(IP5(I1) .LE. IP2(I1)) GO TO 50
  21631. C
  21632. C  INPUT BLOCK EMPTY
  21633. C
  21634.       IF(IP3(I1) .LT. 0) GO TO 40
  21635.       I2 = IP4(I1)
  21636. C*  READ BLOCK IP3(I1) TO BUFFER(I2)
  21637.       IP3(I1) = IP3(I1) + 1
  21638.       CALL RIOIN(INFIL,IP3(I1),BUFFER(I2),LREC,IOS)
  21639.       IP1(I1) =I2 + 4
  21640.       IP2(I1) = BUFFER(I2)
  21641.       IP5(I1) = 1
  21642.       IF(BUFFER(I2+1) .LT. 0) IP3(I1) = -IP3(I1)
  21643.       GO TO 50
  21644.    40 CONTINUE
  21645. C
  21646. C  CURRENT PAGE IS LAST PAGE IN CHAIN
  21647. C
  21648.       IF(NIP.EQ.1) GO TO 100
  21649.       DO 45 I=2,NIP
  21650.    45 IP(I-1) = IP(I)
  21651.       NIP = NIP - 1
  21652.       GO TO 25
  21653.    50 CONTINUE
  21654. C
  21655. C  CURRENT IP(1) TUPLE MOVED
  21656. C  PICK UP NEXT AND LET IT SINK
  21657. C
  21658.       IF(NIP.GT.1) CALL SWSINK(IP,IP1,NIP,BUFFER)
  21659.       GO TO 25
  21660.   100 CONTINUE
  21661. C
  21662. C     ALL DONE
  21663. C
  21664.       RETURN
  21665.       END
  21666.       SUBROUTINE SWVLFS(INFIL,OUTFIL,SCFIL1,SCFIL2,
  21667.      X                 BUFFER,LBUF,LPRU,DPRU,IERR)
  21668.         Include TEXT.BLK
  21669. C
  21670. C  PURPOSE  DRIVER FOR OUT-OF-CORE SORT
  21671. C           OF VARIABLE LENGTH TUPLES
  21672. C
  21673. C  METHOD   A LEAST COST SORT STRATEGY
  21674. C           IS ESTABLISHED BASED UPON
  21675. C           MACHINE DEPENDENT PARAMETERS
  21676. C           THE COST IS BASED UPON
  21677. C           COST FOR POSITIONING ON
  21678. C           MASS STORAGE,MASS STORAGE
  21679. C           TRANSFERS,IN-CORE MOVEMENT
  21680. C           OF DATA AND COMPARISON OF
  21681. C           DATA.
  21682. C           AN N-ARY SORT/MERGE STRATEGY
  21683. C           IS CHOOSEN WHERE 2 LE N LE 9
  21684. C           N IS THE NUMBER OF CHAINS
  21685. C           OF DATA THAT IS MERGED IN
  21686. C           ONE SINGLE MERGE. EACH SORT PASS
  21687. C           MAY REQUIRE SEVERAL SUCH MERGES.
  21688. C
  21689. C
  21690. C  DEFINITION OF VARIABLES
  21691. C
  21692. C  INFIL   FILE NAME OF FILE (SEQ) WHICH    (INT,I)
  21693. C          CONTAINS INPUT TUPLES
  21694. C         INFIL IS UNFORMATTED (BINARY)
  21695. C         EACH TUPLE IS WRITTEN AS A
  21696. C         RECORD AS FOLLOWS
  21697. C         FOR FIXED LENGTH RECORDS
  21698. C           WRITE(INFIL) (TUP(I),I=1,LTUPLE)
  21699. C         FOR VARIABLE LENGTH RECORDS
  21700. C           WRITE(INFIL) L,(TUP(I),I=1,L)
  21701. C
  21702. C  OUTFIL  FILE NAME OF FILE (SEQ) WHICH    (INT,I)
  21703. C          CONTAINS OUTPUT (SORTED) TUPLES
  21704. C          OUTFIL MAY EQ INFIL
  21705. C          FORMAT OF OUTFIL IS THE
  21706. C          SAME AS THAT OF INFIL
  21707. C
  21708. C  SCFIL1  FILE NAME OF (RAN) SCRATCH FILE  (TEXT,I)
  21709. C
  21710. C  SCFIL2  FILE NAME OF (RAN) SCRATCH FILE  (TEXT,I)
  21711. C          NOTE THAT SCFIL1 MUST NOT BE
  21712. C          EQUAL TO SCFIL2
  21713. C
  21714. C  BUFFER  INCORE SCRATCH AREA              (ANY,SCRATCH)
  21715. C
  21716. C  LBUF    LENGTH OF BUFFER                 (INT,I)
  21717. C
  21718. C  LPRU    QUANTUM LENGTH OF RANDOM         (INT,I)
  21719. C          FILE RECORDS
  21720. C
  21721. C  DPRU    DELTA QUANTUM LENGTH OF          (INT,I)
  21722. C          RANDOM FILE RECORDS.
  21723. C          THE LENGTH OF SUCH A RECORD
  21724. C          MUST EQUAL
  21725. C          I*LPRU+DPRU
  21726. C
  21727. C  IERR    ERROR CONDITION                  (INT,O)
  21728. C           0 NORMAL RETURN
  21729. C           1 ERROR IN FILE READ
  21730. C           2 ERROR IN FILE WRITE
  21731. C
  21732. C
  21733. C  DEFINITION OF LOCAL VARIABLES
  21734. C
  21735. C  I1     SCRATCH
  21736. C  I2     SCRATCH,NO OF PAGES IN INITIAL
  21737. C         OFLOADING
  21738. C  I3     SCRATCH,NO OF SORT PASSES,NOT COUNTING
  21739. C         ACTIONS ON SEQUENTIAL FILES
  21740. C         OF WHOLE RANDOM FILES
  21741. C  I4     SCRATCH
  21742. C  I5     SCRATCH
  21743. C  I6     LOW COST SORT ORDER
  21744. C  I7     NO OF INCORE PAGES IN INITIAL
  21745. C         PASS WHERE SEQUENTIAL FILE IS
  21746. C         OFFLOADED
  21747. C  I8     SCRATCH,NO OF TUPLES PER RAN FILE PAGE
  21748. C  I9     SCRATCH,NO OF PAGES ON RANDOM FILES
  21749. C  I10    SCRATCH,LENGTH OF RANDOM FILE PAGE
  21750. C  COST   COST OF OPTIMUM SORT STRATEGY
  21751. C  NRECS  NO OF PAGES ON RANDOM SCRATCH FILE
  21752. C  LREC   LENGTH OF RANDOM FILE PAGE
  21753. C
  21754.         Include SRTCOM.BLK
  21755.       DIMENSION BUFFER(1)
  21756.       INTEGER DPRU,OUTFIL
  21757.       INTEGER SCARR1,SCARR2
  21758.       REAL*8 SCFIL1,SCFIL2
  21759.       INTEGER CHAIN1,OUTREC
  21760.       INTEGER TUPL
  21761.       LOGICAL SWITCH
  21762.       I6 = 0
  21763.       I1 = 2*LPRU
  21764.       I11 = 2*DPRU
  21765.       TUPL = LTUPLE/NSORT
  21766.       DO 100 I=2,9
  21767.       I1 = I1 + LPRU
  21768.       I11 = I11 + DPRU
  21769.       I10 = LPRU*((LBUF-I11)/I1) + DPRU
  21770.       IF(I10 .LT. LTUMAX+2) GO TO 110
  21771.       I8 = (I10 - 2 - TUPL/2) / TUPL
  21772.       IF(I8 .EQ. 0) I8 = 1
  21773.       I2 = (LTUMIN*(LBUF-LTUMAX-I10))/((LTUMIN+1)*(I10-2))
  21774. C
  21775. C  I2 IS NO OF INCORE BLOCKS IN
  21776. C     INITIAL PASS
  21777. C
  21778.       I9 =(NSORT+I8-1)/I8
  21779.       I3 = 1
  21780.       I4 = I2
  21781.    10 CONTINUE
  21782.       I5 = I4
  21783.       I4 = I4*I + I5
  21784.       IF (I4 .GE. I9) GO TO 20
  21785.       I4 = I4 - I5
  21786.       I3 = I3 + 1
  21787.       GO TO 10
  21788.    20 CONTINUE
  21789. C
  21790.       CALL SWCOST(I3,I9,I10,I,A1)
  21791.       IF(I6 .GT. 0) GO TO 30
  21792.       GO TO 35
  21793.    30 CONTINUE
  21794.       IF(A1 .GE. COST) GO TO 90
  21795.    35 COST = A1
  21796.       I7 = I2
  21797.       I6 = I
  21798.       LREC = I10
  21799.    90 CONTINUE
  21800.       IF(I3 .EQ. 1) GO TO 110
  21801.   100 CONTINUE
  21802.   110 CONTINUE
  21803. C
  21804. C  OPTIMUM SORT STRATEGY DETERMINED
  21805. C
  21806. C  OPEN SORT SCRATCH FILES
  21807. C
  21808.       SCARR1 = 35
  21809.       SCARR2 = 36
  21810.       CALL DROPF(SCFIL1)
  21811.       CALL DROPF(SCFIL2)
  21812.       CALL RIOOPN(SCFIL1,SCARR1,LREC,IOS)
  21813.       CALL RIOOPN(SCFIL2,SCARR2,LREC,IOS)
  21814.       CALL SWVLLO(BUFFER,LREC,I7,INFIL,SCARR1,NI)
  21815. C
  21816. C     NPASS IS THE NUMBER OF RANDOM TO RANDOM MERGES
  21817. C     NI IS THE NUMBER OF CHAINS ON THE INPUT FILE
  21818. C     NO IS THE NUMBER OF CHAINS ON THE OUTPUT FILE
  21819. C     NCHAIN IS THE NUMBER OF CHAINS TO MERGE
  21820. C     LCHAIN IS THE NUMBER OF PAGES PER INPUT CHAIN
  21821. C
  21822.       LCHAIN = I7
  21823.       NCHAIN = I6
  21824.       NO = NI
  21825.       SWITCH = .TRUE.
  21826. C
  21827. C     OUTER LOOP ON THE NUMBER OF PASSES
  21828.       IF(NI .LE. I6) GO TO 250
  21829.   130 CONTINUE
  21830.       NI = NO
  21831.       NO = (NI-1)/NCHAIN
  21832.       NO = NO + 1
  21833.       SWITCH = .NOT. SWITCH
  21834.       IF(SWITCH) CALL DROPF(SCFIL1)
  21835.       IF(SWITCH) CALL RIOOPN(SCFIL1,SCARR1,LREC,IOS)
  21836.       IF(.NOT.SWITCH) CALL DROPF(SCFIL2)
  21837.       IF(.NOT.SWITCH) CALL RIOOPN(SCFIL2,SCARR2,LREC,IOS)
  21838.       INC = LCHAIN*NCHAIN
  21839. C
  21840. C     INNER LOOP ON NUMBER OF OUTPUT CHAINS
  21841. C
  21842.       INCH = 1
  21843.       DO 150 J=1,NO
  21844.       CHAIN1 = (J-1)*INC + 1
  21845.       OUTREC = 0
  21846.       NCH = NCHAIN
  21847.       IF(J.EQ.NO) NCH = NI - (NO-1)*NCHAIN
  21848.       IF(SWITCH) CALL SWSMVL(BUFFER,CHAIN1,NCH,LCHAIN,OUTREC,J,
  21849.      X       INCH,LREC,SCARR2,SCARR1)
  21850.       IF(.NOT.SWITCH) CALL SWSMVL(BUFFER,CHAIN1,NCH,LCHAIN,OUTREC,J,
  21851.      X       INCH,LREC,SCARR1,SCARR2)
  21852.       INCH = INCH + NCH
  21853.   150 CONTINUE
  21854.       LCHAIN = LCHAIN * NCHAIN
  21855.       IF(NO .GT. I6+1) GO TO 130
  21856.   250 CONTINUE
  21857. C
  21858. C     CALL SWUNVL TO CREATE OUTPUT SEQUENTIAL FILE
  21859. C
  21860.       CHAIN1 = 1
  21861.       NCH = NO
  21862.       INCH = 1
  21863.       IF(SWITCH) CALL SWUNVL(BUFFER,CHAIN1,NCH,LCHAIN,
  21864.      X      INCH,LREC,SCARR1,OUTFIL)
  21865.       IF(.NOT.SWITCH) CALL SWUNVL(BUFFER,CHAIN1,NCH,LCHAIN,
  21866.      X      INCH,LREC,SCARR2,OUTFIL)
  21867. C
  21868. C     RETURN THE SCRATCH RANDOM FILES
  21869. C
  21870.       CALL DROPF(SCFIL1)
  21871.       CALL DROPF(SCFIL2)
  21872.       RETURN
  21873.       END
  21874.       SUBROUTINE SWVLLO(BUFFER,LREC,NREC,INFIL,OUTFIL,NI)
  21875.         Include TEXT.BLK
  21876. C
  21877. C  PURPOSE  LOADING PASS FOR OUT-OF-CORE SORT
  21878. C           OF VARIABLE LENGTH TUPLES
  21879. C
  21880. C  TIMING   UNKNOWN
  21881. C
  21882. C  DEFINITION OF VARIABLES
  21883. C
  21884. C  BUFFER   CORE SCRATCH AREA OF                  (SCRATCH)
  21885. C           SUFFICIENT LENGTH
  21886. C
  21887. C  LBUF     LENGTH OF BUFFER                      (INT,I)
  21888. C
  21889. C  LREC     LENGTH, IN WORDS, OF OUTPUT RECORD    (INT,I)
  21890. C
  21891. C
  21892. C  INFIL   FILE NAME OF FILE (SEQ) WHICH    (INT,I)
  21893. C           CONTAINS INPUT TUPLES
  21894. C           INFIL IS UNFORMATTED (BINARY)
  21895. C           EACH TUPLE IS WRITTEN AS A
  21896. C           RECORD AS FOLLOWS
  21897. C           FOR FIXED LENGTH RECORDS
  21898. C             WRITE(INFIL) (TUP(I),I=1,LENGTH)
  21899. C           FOR VARIABLE LENGTH RECORDS
  21900. C             WRITE(INFIL) L,(TUP(I),I=1,L)
  21901. C
  21902. C  OUTFIL   FET FOR FILE      (RANDOM) WHICH      (INT,I)
  21903. C           CONTAINS CHAINS OF SORTED TUPLES
  21904. C           EACH CHAIN CONTAINS ONE OR MORE BLOCKS
  21905. C           EACH BLOCK CONTAINS
  21906. C            WORD 1   = NO TUPLES IN BLOCK
  21907. C            WORD 2   = CHAIN NO,NEG FOR LAST BLOCK
  21908. C            WORD 3   = RECORD NUMBER IN CHAIN
  21909. C            WORD 4FF = TUPLES IN SORTED ORDER
  21910. C
  21911. C  NI         NUMBER OF CHAINS GENERATED
  21912. C
  21913.       INTEGER BUFFER(1)
  21914.       INTEGER OUTFIL
  21915. C
  21916. C  DEFINITION OF LOCAL VARIABLES
  21917. C  FIRST AN EXPLANATION OF HOW BUFFER IS USED
  21918. C
  21919. C  ON TOP OF BUFFER IS TUPLE INPUT AREA,LENGTH LTUMAX-1
  21920. C  SECOND IS RECORD OUTPUT AREA,LENGTH LREC
  21921. C  THIRD IS TUPLE SORT AREA,LENGTH NREC*(LREC-2)
  21922. C  FOUTH AND LAST IS POINTER AREA,LENGTH (NREC*(LREC-2))/LTUMIN
  21923. C
  21924. C  I1  ADDRESS TO FIRST WORD IN TUPLE AREA
  21925. C  I2  ADDRESS TO NEXT TUPLE (LENGTH WORD)
  21926. C  I3  AVAILABLE ROOM IN TUPLE AREA
  21927. C  I4  ADDRESS TO FIRST WORD IN POINTER AREA
  21928. C  I5  ADDRESS TO CURRENT POINTER
  21929. C  I6  CURRENT TUPLE ON INPUT FILE
  21930. C  I8  ADDRESS TO CURRENT TUPLE IN OUTPUT BUFFER
  21931. C  I9  NUMBER OF TUPLES IN OUTPUT BUFFER
  21932. C  I10 NUMBER OF OUTPUT RECORDS CURRENTLY WRITTEN
  21933. C      IN CHAIN
  21934. C  I11 LENGTH OF TUPLE IN INPUT AREA
  21935. C
  21936.         Include SRTCOM.BLK
  21937.       REWIND INFIL
  21938.       I1 = LTUMAX + LREC
  21939.       LTUM = LTUMAX - 1
  21940.       I2 = I1
  21941.       I33 = NREC*(LREC - 3)
  21942.       I3 = I33
  21943.       I4 = I1 + I3
  21944.       I5 = I4
  21945.       I6 = 0
  21946.       NI = 0
  21947.       ILAST = 0
  21948.    10 CONTINUE
  21949. C
  21950. C  FILL TUPLE AREA
  21951. C
  21952.       I6 = I6 + 1
  21953.       IF(I6 .GT. NSORT) GO TO 100
  21954.       READ(INFIL) I11,(BUFFER(J2),J2=1,I11)
  21955.    12 CONTINUE
  21956.       IF(I11 .GE. I3) GO TO 20
  21957.       DO 15 J2=1,I11
  21958.    15 BUFFER(I2+J2) = BUFFER(J2)
  21959.       BUFFER(I2) = I11
  21960.       BUFFER(I5) = I2 + 1
  21961.       I2 = I2 + I11 + 1
  21962.       I5 = I5 + 1
  21963.       I3 = I3 - I11 - 1
  21964.       GO TO 10
  21965.    20 CONTINUE
  21966. C
  21967. C  TUPLE AREA FULL,OR NO
  21968. C  MORE TUPLES ON INPUT FILE
  21969. C  SORT,UNLOAD
  21970. C
  21971.       CALL SWICST(BUFFER,BUFFER(I4),I5-I4)
  21972.       NI = NI + 1
  21973.       BUFFER(LTUM+2) = NI
  21974.       J1 = I4
  21975.       I10 = 0
  21976.    25 I9 = 0
  21977.       I8 = LTUM + 4
  21978.    30 CONTINUE
  21979.       J2 = BUFFER(J1) - 1
  21980.       J3 = BUFFER(J2)
  21981.       IF(J3+I8 .GE. I1) GO TO 50
  21982.       DO 40 J4=1,J3
  21983.    40 BUFFER(I8+J4) = BUFFER(J2+J4)
  21984.       I9 = I9 + 1
  21985.       J1 = J1 + 1
  21986.       BUFFER(I8) = J3
  21987.       I8 = I8 + J3 + 1
  21988.       IF(J1 .LT. I5) GO TO 30
  21989.       BUFFER(LTUM+2) = -NI
  21990.    50 CONTINUE
  21991. C
  21992. C  WRITE OUTPUT BUFFER
  21993. C
  21994.       BUFFER(LTUM+1) = I9
  21995.       I10 = I10 + 1
  21996.       IF(I10 .EQ. NREC .AND. ILAST .EQ. 0) BUFFER(LTUM+2) = -NI
  21997.       BUFFER(LTUM+3) = I10
  21998.       CALL RIOOUT(OUTFIL,0,BUFFER(LTUM+1),LREC,IOS)
  21999.       IF(BUFFER(LTUM+2).GT.0) GO TO 25
  22000. C
  22001. C  SHUFFLE TUPLE AREA IF REQUIRED
  22002. C
  22003.       I2 = I1
  22004.       I3 = I33
  22005.       I55 = I5
  22006.       I5 = I4
  22007.       IF(J1 .LT. I55) GO TO 60
  22008.       IF(ILAST .EQ. 0) GO TO 12
  22009.       RETURN
  22010.    60 CONTINUE
  22011.       NUM = I55 - J1
  22012.       CALL SWSHEL(BUFFER(J1),NUM)
  22013.    65 CONTINUE
  22014.       J2 = BUFFER(J1) - 1
  22015.       J3 = BUFFER(J2)
  22016.       DO 70 J4=1,J3
  22017.    70 BUFFER(I2+J4) = BUFFER(J2+J4)
  22018.       BUFFER(I2) = J3
  22019.       BUFFER(I5) = I2 + 1
  22020.       I2 = I2 + J3 + 1
  22021.       I5 = I5 + 1
  22022.       I3 = I3 - J3 - 1
  22023.       J1 = J1 + 1
  22024.       IF(J1 .LT. I55) GO TO 65
  22025.       GO TO 12
  22026.   100 CONTINUE
  22027. C
  22028. C  ALL TUPLES READ FROM INFIL
  22029. C
  22030.       ILAST = 1
  22031.       GO TO 20
  22032.       END
  22033. c    INTERFACE TO SUBROUTINE TIME (N,STR)
  22034. c    CHARACTER*10 STR [NEAR,REFERENCE]
  22035. c    INTEGER*2 N [VALUE]
  22036. c    END
  22037.     SUBROUTINE SYSTIM(TTSTR)
  22038.     Real*8 ttstr
  22039.     Character*8 ttstc
  22040.     Real*8 tst
  22041.     Equivalence (tst,ttstc)
  22042.     INTEGER NN,ihr,imn,isc
  22043. C
  22044. C  CALL DATE AND TIME (NOTE THAT THE STRING LENGTH IS PASSED
  22045. C  AS THE FIRST ARGUMENT)
  22046. C
  22047.     CALL TIME (NN)
  22048.     ihr=nn/3600
  22049.     nn=nn-3600*ihr
  22050.     imn=nn/60
  22051.     isc=nn-60*imn
  22052. c
  22053.     write(ttstc,100)ihr,char(58),imn,char(58),isc
  22054. 100    format(I2.2,1A1,I2.2,1a1,I2.2)
  22055.     ttstr=tst
  22056. C RETURNS SYSTEM TIME IN ASCII AS HH:MM:SS
  22057.     RETURN
  22058.     END
  22059.       SUBROUTINE TALLY
  22060.         Include TEXT.BLK
  22061. C
  22062. C  PURPOSE:  THIS ROUTINE PROCESSES THE RIM TALLY COMMAND
  22063. C
  22064. C  PARAMETERS: NONE
  22065. C
  22066.         Include RMATTS.BLK
  22067.         Include CONST4.BLK
  22068.         Include RIMCOM.BLK
  22069.         Include WHCOM.BLK
  22070.         Include FILES.BLK
  22071.         Include MISC.BLK
  22072.         Include BUFFER.BLK
  22073.  
  22074.         Include SELCOM.BLK
  22075.         Include TUPLEA.BLK
  22076. C
  22077.       LOGICAL DONE
  22078.       LOGICAL ITALLY
  22079. C
  22080. C  THE FOLLOWING FUNNY LOOKING STUFF IS TO MAKE THE TITLE
  22081. C  "NUMBER OF OCCURANCES" WORK. FTN5, PORTABLE, ETC. -----
  22082. C
  22083.       INTEGER HEADER(6)
  22084.       EQUIVALENCE (HEADER(1),K4HEAD(1))
  22085. C
  22086. C     SET LPP AND MCPL
  22087. C
  22088.       LPP = 10000000
  22089.       IF(.NOT.CONNO) LPP = 56
  22090.       MCPL = 50
  22091.       IF(.NOT.CONNO)MCPL = 100
  22092.       IF(ULPP.NE.0) LPP = ULPP
  22093.       IF(UMCPL.NE.0) MCPL = UMCPL - 25
  22094.       IF(MCPL.LT.10) MCPL = 10
  22095. C
  22096. C     CALL SELPAR TO SET SELCOM BLOCK
  22097. C
  22098.       ITALLY = .TRUE.
  22099.       CALL SELPAR(ITALLY)
  22100.       IF(NUMATT.LE.0) GO TO 900
  22101.       NLINE = 3
  22102. C
  22103. C  PUT "NUMBER OF OCCURANCES" INTO THE TITLE LINE
  22104. C
  22105.       NPOS1 = NUMCOL(1) + 2
  22106.       NPOS = NPOS1 + 3
  22107.       CALL FILCH(TITLE,NPOS1,3,BLANK)
  22108.       CALL FILCH(MINUS,NPOS1,3,BLANK)
  22109.       NPOSH = NPOS
  22110.       DO 20 K=1,6
  22111.       CALL STRMOV(HEADER(K),1,4,TITLE,NPOSH)
  22112.       NPOSH = NPOSH + 4
  22113.    20 CONTINUE
  22114.       CALL FILCH(MINUS,NPOS,21,K4MNUS)
  22115.       NUM = NPOS + 20
  22116.       WRITE (NOUTR,30)
  22117.    30 FORMAT(1H )
  22118.       CALL SPOUT(TITLE,NUM)
  22119.       CALL SPOUT(MINUS,NUM)
  22120. C
  22121. C  GET THE ATTRIBUTE LENGTH
  22122. C
  22123.       N2 = ATTWDS
  22124. C
  22125. C  SET UP THE NUMBER OF WORDS THAT WERE SORTED ON
  22126. C
  22127.       LOOP = 1
  22128.       IF(ATTYPE.EQ.KZTEXT) LOOP = 20/CHPWD
  22129.       IF(ATTYPE.EQ.KZDOUB) LOOP = 2
  22130.       IF(ATTYPE.EQ.KZDVEC) LOOP = 2
  22131.       IF(ATTYPE.EQ.KZDMAT) LOOP = 2
  22132.       IF(LOOP.GT.N2) LOOP = N2
  22133. C
  22134. C  SET UP A SCRATCH AREA IN BUFFER TO HOLD TUPLES
  22135. C
  22136. C  ESTABLISH THE BUFFER POINTER
  22137. C
  22138.       CALL BLKCHG(10,MAXCOL,1)
  22139.       KQ1 = BLKLOC(10) - 1
  22140. C
  22141. C  RETRIVE THE SORTED ATTRIBUTE VALUES FROM THE SORT FILE
  22142. C
  22143.       CALL GTSORT(IP,1,-1,N2)
  22144. C
  22145. C  GET THE VERY FIRST VALUE.
  22146. C
  22147.       NPRT = 0
  22148.       LIMTUT = LIMTU
  22149.       LIMTU = ALL9S
  22150.       CALL GTSORT(IP,1,1,N2)
  22151.   100 CONTINUE
  22152.       NOCC = 1
  22153. C
  22154. C  USE BUFFER AS A SCRATCH ARRAY TO HOLD THE ATTRIBUTE VALUE
  22155. C
  22156.       DO 110 N=1,N2
  22157.       BUFFER(KQ1+N) = BUFFER(IP+N-1)
  22158.   110 CONTINUE
  22159.   200 CONTINUE
  22160.       CALL GTSORT(IP,1,1,N2)
  22161.       IF(RMSTAT.NE.0) GO TO 400
  22162.       DO 210 N=1,LOOP
  22163.       IF(BUFFER(IP+N-1).NE.BUFFER(KQ1+N)) GO TO 400
  22164.   210 CONTINUE
  22165.       NOCC = NOCC + 1
  22166.       GO TO 200
  22167. C
  22168. C  THERE HAS BEEN A VALUE CHANGE. PRINT THE VALUE AND COUNT.
  22169. C
  22170.   400 CONTINUE
  22171.       NPRT = NPRT + 1
  22172.       IF(NPRT.LE.LIMTUT) GO TO 405
  22173. C
  22174. C  ALL DONE - CLOSE THE SORT FILE
  22175. C
  22176.       LIMTU = 0
  22177.       CALL GTSORT(IP,1,1,N2)
  22178.       GO TO 999
  22179.   405 CONTINUE
  22180.       CURPOS(1) = 1
  22181.       CALL FILCH(LINE,1,NUM,BLANK)
  22182.       CALL SELOUT(BUFFER(KQ1+1),1,DONE)
  22183.       IF(NLINE.LT.LPP) GO TO 420
  22184.       NLINE = 3
  22185.       IF(.NOT.CONNO) WRITE(NOUTR,410)
  22186.   410 FORMAT(1H1)
  22187.       WRITE(NOUTR,30)
  22188.       CALL SPOUT(TITLE,NUM)
  22189.       CALL SPOUT(MINUS,NUM)
  22190.   420 CONTINUE
  22191. C
  22192. C  PUT THE COUNT INTO LINE AND PRINT
  22193. C
  22194.       CALL ITOC(LINE,NPOS1+5,8,NOCC,IERR)
  22195.       CALL SPOUT(LINE,NUM)
  22196.       NLINE = NLINE + 1
  22197.       IF(RMSTAT.EQ.0) GO TO 100
  22198.       GO TO 999
  22199. C
  22200. C     NO VALID ATTRIBUTES
  22201. C
  22202.   900 CONTINUE
  22203.       WRITE (NOUT,910)
  22204.   910 FORMAT(40H -WARNING- NO VALID ATTRIBUTES SPECIFIED )
  22205.   999 CONTINUE
  22206.       LIMTU = LIMTUT
  22207.       CALL BLKCLR(10)
  22208.       RETURN
  22209.       END
  22210.       SUBROUTINE TOLED(K,V,N)
  22211.         Include TEXT.BLK
  22212. C
  22213. C     THIS ROUTINE APPLIES A TOLERANCE TO A DOUBLE ROUTINE
  22214. C
  22215. C     K IS LOCBOO VALUE
  22216. C     V(N) IS DOUBLE ARRAY
  22217. C
  22218.         Include FLAGS.BLK
  22219.       DOUBLE PRECISION V(N)
  22220.       DOUBLE PRECISION X
  22221.       X = TOL
  22222.       IF(K.GT.5) X = -X
  22223.       IF(PCENT) GO TO 50
  22224.       DO 20 I=1,N
  22225.       V(I) = V(I) - X
  22226.    20 CONTINUE
  22227.       RETURN
  22228.    50 CONTINUE
  22229.       DO 70 I=1,N
  22230.       V(I) = V(I)*(1.-X)
  22231.    70 CONTINUE
  22232.       RETURN
  22233.       END
  22234.       SUBROUTINE TOLER(K,V,N)
  22235.         Include TEXT.BLK
  22236. C
  22237. C     THIS ROUTINE APPLIES A TOLERANCE TO A REAL ROUTINE
  22238. C
  22239. C     K IS LOCBOO VALUE
  22240. C     V(N) IS REAL ARRAY
  22241. C
  22242.         Include FLAGS.BLK
  22243.       DIMENSION V(N)
  22244.       X = TOL
  22245.       IF(K.GT.5) X = -TOL
  22246.       IF(PCENT) GO TO 50
  22247.       DO 20 I=1,N
  22248.       V(I) = V(I) - X
  22249.    20 CONTINUE
  22250.       RETURN
  22251.    50 CONTINUE
  22252.       DO 70 I=1,N
  22253.       V(I) = V(I)*(1.-X)
  22254.    70 CONTINUE
  22255.       RETURN
  22256.       END
  22257.       LOGICAL FUNCTION TTY(I)
  22258. C
  22259. C  DUMMY ROUTINE FOR TTY ON THE VAX -- ALWAYS TRUE
  22260. C
  22261.       TTY = .TRUE.
  22262.       RETURN
  22263.       END
  22264.       SUBROUTINE TYPER(ATYPE,VECMAT,TYPE)
  22265.         Include TEXT.BLK
  22266. C
  22267. C     THIS ROUTINE TURNS RIM TYPES SUCH AS IVEC
  22268. C     INTO TWO USEFUL TYPES.
  22269. C
  22270. C     ATYPE...RIM TYPE
  22271. C     VECMAT..3HVEC,3HMAT OR BLANKS
  22272. C     TYPE....3HINT,4HREAL,4HDOUB,4HTEXT
  22273. C
  22274.         Include RMATTS.BLK
  22275.         Include MISC.BLK
  22276.         Include CONST4.BLK
  22277. C
  22278.       INTEGER ATYPE,VECMAT,TYPE
  22279.       VECMAT = IBLANK
  22280.       TYPE = ATYPE
  22281.       IF(TYPE.EQ.KZTEXT) RETURN
  22282.       IF(TYPE.EQ.KZINT ) RETURN
  22283.       IF(TYPE.EQ.KZREAL) RETURN
  22284.       IF(TYPE.EQ.KZDOUB) RETURN
  22285.       VECMAT = KZVEC
  22286.       TYPE = K4NONE
  22287.       IF(ATYPE.EQ.KZIVEC) TYPE = KZINT
  22288.       IF(ATYPE.EQ.KZRVEC) TYPE = KZREAL
  22289.       IF(ATYPE.EQ.KZDVEC) TYPE = KZDOUB
  22290.       IF(TYPE.NE.K4NONE) RETURN
  22291.       VECMAT = KZMAT
  22292.       IF(ATYPE.EQ.KZIMAT) TYPE = KZINT
  22293.       IF(ATYPE.EQ.KZRMAT) TYPE = KZREAL
  22294.       IF(ATYPE.EQ.KZDMAT) TYPE = KZDOUB
  22295.       RETURN
  22296.       END
  22297.       SUBROUTINE UNDATA (ALL,IRCNTR,IDAY,WORD1,LHASH,NAMOWN)
  22298.         Include TEXT.BLK
  22299. C
  22300. C  PURPOSE:  UNLOADS THE DATA OF A DATABASE.
  22301. C
  22302. C  INPUTS:
  22303. C          ALL---------TRUE IF ALL RELATIONS ARE SPECIFIED.
  22304. C          IRCNTR------NUMBER OF RELATIONS IF SPECIFIED (ALL IS FALSE).
  22305. C          IDAY--------DAY CODE FOR HASH
  22306. C          WORD1--------COMMAND SPECIFIED.
  22307. C          LHASH--------LOGICAL SWITCH FOR HASH
  22308. C          NAMOWN--------FOR CHECKING PERMISSION
  22309. C          NAMOWN-------NAMOWN TO PASS TO CHKREL
  22310. C          NAMDB--------NAMDB FOR DEFINE.
  22311. C
  22312.         Include RMATTS.BLK
  22313.         Include RMKEYW.BLK
  22314.         Include CONST4.BLK
  22315.         Include DCLAR6.BLK
  22316.         Include FILES.BLK
  22317.         Include MISC.BLK
  22318.         Include BUFFER.BLK
  22319.         Include RIMCOM.BLK
  22320.         Include TUPLEA.BLK
  22321.         Include TUPLER.BLK
  22322.         Include DCLAR1.BLK
  22323.         Include DCLAR2.BLK
  22324.         Include DCLAR3.BLK
  22325.       INTEGER LINE (20),QUOTE,DONE,
  22326.      X                START,ATTSTR,ATTCNT,TUPLE,STEP
  22327.       REAL*8 IREL(100)
  22328.       INTEGER ATDATA(250,5),STAT
  22329.       EQUIVALENCE (BUFFER(1),IREL(1)),(BUFFER(201),ATDATA(1,1))
  22330.       LOGICAL ALL,PERM,LHASH
  22331. C
  22332. C
  22333. C
  22334. C
  22335.       WRITE (NOUTR,50)
  22336.    50 FORMAT (1X,7HNOCHECK)
  22337.       J = LOCREL (BLANK)
  22338.       I = 0
  22339.       CALL FILCH (LINE,1,80,IBLANK)
  22340.       MPW1 = BLANK
  22341.    75 CONTINUE
  22342. C
  22343. C  GET MODIFY PASSWORD
  22344. C
  22345.       IF (ALL) GO TO 80
  22346. C
  22347. C  SUBSET OF THE DATA
  22348. C
  22349.       I = I + 1
  22350.       IF (I .GT. IRCNTR) GO TO 800
  22351.       RNAME = IREL(I)
  22352.       J = LOCREL (RNAME)
  22353.       GO TO 85
  22354.    80 CONTINUE
  22355.       CALL CHKREL (PERM,WORD1,ISTAT,NAMOWN)
  22356.       IF (ISTAT .NE. 0) GO TO 800
  22357.       IF  (.NOT. PERM) GO TO 80
  22358.    85 CONTINUE
  22359.       IF ((MPW .EQ. K4NONE) .OR. (MPW .EQ. MPW1)) GO TO 100
  22360.       CALL STRMOV(KWUSER,1,4,LINE,2)
  22361.       CALL PUTT(LINE,7,K4QUOT)
  22362.       NUM = 16
  22363.       IF (LHASH) NUM = 24
  22364.       IF (LHASH) CALL HASHIN (MPW,IDAY,LINE,8)
  22365.       IF (.NOT. LHASH) CALL STRMOV (MPW,1,8,LINE,8)
  22366.       CALL PUTT (LINE,NUM,K4QUOT)
  22367.       CALL SPOUT (LINE,NUM)
  22368.       MPW1 = MPW
  22369.   100 CONTINUE
  22370. C
  22371. C  WRITE LOAD COMMAND
  22372. C
  22373.       WRITE (NOUTR,150) NAME
  22374.   150 FORMAT (1X,4HLOAD,1X,A8)
  22375.       J = LOCATT (BLANK,NAME)
  22376.       IND = 1
  22377.       ATTCNT = 0
  22378.   160 CALL ATTGET (ISTAT)
  22379.       IF (ISTAT .NE. 0) GO TO 250
  22380.       ATTCNT = ATTCNT + 1
  22381.       ATDATA (ATTCNT,1) = ATTCOL
  22382.       ATDATA (ATTCNT,2) = ATTCHA
  22383.       ATDATA (ATTCNT,3) = ATTWDS
  22384. C
  22385. C  GET ATTRIBUTE TYPE AND STRUCTURE
  22386. C
  22387.       CALL TYPER (ATTYPE,ATDATA(ATTCNT,5),ATDATA(ATTCNT,4))
  22388.       GO TO 160
  22389.   250 CONTINUE
  22390.       NEXTID = RSTART
  22391.       STAT = 0
  22392. C
  22393. C  PROCESS THE TUPLES
  22394. C
  22395.       DO 600 NEXTUP = 1,NTUPLE
  22396.       NC = 2
  22397.       KK = 0
  22398.       DONE = 0
  22399. C
  22400. C  GET THE DATA -- NC IS THE NUMBER OF CHARACTERS
  22401. C
  22402.       CALL GETDAT(IND,NEXTID,ITUP,LEN)
  22403.       CALL FILCH (LINE,1,80,IBLANK)
  22404. C
  22405. C  PROCESS THE TUPLE ACCORDING TO THE NUMBER OF ATTRIBUTES
  22406. C
  22407.       DO 500 LL = 1,ATTCNT
  22408.       STEP = 1
  22409.       ICOUNT = ATDATA (LL,1)
  22410.       IF (LL .EQ. ATTCNT) DONE = 1
  22411.       LEN1 = ATDATA (LL,2)
  22412.       LEN2 = ATDATA (LL,3)
  22413.       ATTSTR = ATDATA (LL,5)
  22414.       TUPLE = ITUP + ICOUNT - 1
  22415. C
  22416. C  CHECK TO SEE IF VARYING LENGTH -- IF SO GET NEW LENGTHS
  22417. C
  22418.       IF (LEN2 .NE. 0) GO TO 265
  22419. C
  22420. C  VARYING ATTRIBUTE
  22421. C
  22422. C  CHECK TO SEE IF VARYING SCALAR--IF SO, CHANGE TO VECTOR
  22423.       IF (ATTSTR .EQ. IBLANK) ATTSTR = KZVEC
  22424.       TUPLE = BUFFER (TUPLE) + ITUP - 1
  22425.       LEN2 = BUFFER (TUPLE)
  22426.       LEN1 = BUFFER (TUPLE + 1)
  22427.       TUPLE = TUPLE + 2
  22428.   265 CONTINUE
  22429.       ATTYPE = ATDATA (LL,4)
  22430.       IF (ATTYPE .NE. KZDOUB) GO TO 270
  22431.       LEN2 = LEN2/2
  22432.       STEP = 2
  22433.   270 CONTINUE
  22434.       IF(BUFFER(TUPLE).NE.NULL) GO TO 272
  22435. C
  22436. C  NULL VALUE - UNLOAD -0- ONLY
  22437. C
  22438.       CALL STRMOV(NULL,1,3,LINE,NC)
  22439.       NC = NC + 4
  22440.       IF(DONE.EQ.1) STAT = 1
  22441.       IF(NC.GE.60) CALL WRLINE(NC,STAT,LINE)
  22442.       GO TO 500
  22443.   272 CONTINUE
  22444.       IF (ATTYPE .NE. KZTEXT) GO TO 300
  22445. C
  22446. C  TEXT ITEM -- LEN1 IS NUMBER OF CHARACTERS
  22447. C
  22448.       CALL PUTT (LINE,NC,K4QUOT)
  22449. C
  22450. C  TEXT PROCESSING SECTION
  22451. C
  22452.       START = 1
  22453.       NC = NC + 1
  22454.       NONBLK = NSCAN (BUFFER(TUPLE),LEN1,-LEN1,IBLANK,1,1)
  22455. C
  22456. C  CHECK FOR BLANK LINE
  22457. C
  22458.       IF (NONBLK .EQ. 0) NONBLK = 1
  22459. C
  22460. C  CHECK FOR DOUBLE QUOTES
  22461. C
  22462.   290 CONTINUE
  22463.       ICHAR = NONBLK
  22464.       QUOTE = LSTRNG (BUFFER(TUPLE),START,NONBLK,K4QUOT,1,1)
  22465.       IF (QUOTE .NE. 0) ICHAR = (QUOTE - START + 1)
  22466. C
  22467. C  CHECK TO SEE IF THE TEXT STRING CAN FIT ON THE LINE
  22468. C
  22469.       IF ((NC + ICHAR) .GT. 60) ICHAR = 60 - NC
  22470.       IF(ICHAR.EQ.0) ICHAR = 1
  22471.       CALL STRMOV (BUFFER (TUPLE),START,ICHAR,LINE,NC)
  22472.       NC = NC + ICHAR
  22473. C
  22474. C  CHECK TO SEE IF WE ARE DONE
  22475. C
  22476.       IF (ICHAR .NE. (QUOTE - START + 1)) GO TO 295
  22477. C
  22478. C  NOT DONE -- HAVE A DOUBLE QUOTE
  22479. C
  22480.       CALL PUTT (LINE,NC,K4QUOT)
  22481.       NC = NC + 1
  22482.   295 CONTINUE
  22483.       START = START + ICHAR
  22484.       NONBLK = NONBLK - ICHAR
  22485. C
  22486. C  CHECK FOR FULL LINE
  22487. C
  22488.       IF ((NONBLK .NE. 0) .AND. (NC .GE. 60))
  22489.      X             CALL WRLINE (NC,STAT,LINE)
  22490. C
  22491. C  CHECK TO MAKE SURE SPLIT TEXT BEGINS IN COL. 1
  22492. C
  22493.       IF ((NONBLK .NE. 0) .AND. (NC .EQ. 2)) NC = 1
  22494. C
  22495. C  SPLIT LINE TEXT ATTRIBUTE OR DOUBLE QUOTE
  22496. C
  22497.       IF (NONBLK .NE. 0) GO TO 290
  22498. C
  22499. C  DONE WITH PROCESSING TEXT ITEM -- ADD QUOTES
  22500. C
  22501. C
  22502. C  LENGTH OF TEXT ATTRIBUTE IS STORED IN LEN2
  22503. C
  22504.   298 CONTINUE
  22505.       IF (DONE .EQ. 1) STAT = 1
  22506.       CALL PUTT (LINE,NC,K4QUOT)
  22507.       NC = NC + 2
  22508.       IF (NC .GE. 60) CALL WRLINE (NC,STAT,LINE)
  22509.       GO TO 500
  22510. C
  22511. C  PROCESS REAL AND INTEGER STUFF
  22512. C
  22513.   300 CONTINUE
  22514.       MATLEN = 1
  22515. C
  22516. C  PROCESS REAL OR INTEGER ATTRIBUTE (MATRIX,VECTOR, OR SCALAR)
  22517. C
  22518.       IF (ATTSTR .NE. KZMAT) GO TO 315
  22519. C
  22520. C  MATRIX PROCESSING -- NEED TO SET MATLEN AND CHANGE LEN2
  22521. C  TO THE NUMBER OF COLUMNS
  22522. C
  22523.       MATLEN = LEN1
  22524.       IF (LEN1 .NE. 0) LEN2 = LEN2/LEN1
  22525.       CALL PUTT (LINE,NC,K4LPAR)
  22526.       NC = NC + 1
  22527.   315 CONTINUE
  22528.       DO 350 KK = 1,LEN2
  22529.       IF ((((LEN2 .EQ. 1) .AND. (ATTSTR .NE. KZVEC)) .OR. (KK .GT. 1))
  22530.      X        .AND. (ATTSTR .NE. KZMAT)) GO TO 320
  22531.       CALL PUTT (LINE,NC,K4LPAR)
  22532.       NC = NC + 1
  22533.   320 CONTINUE
  22534.       DO 330 J = 1,MATLEN
  22535. C
  22536. C  CHECK TO SEE IF LAST DATA IN TUPLE -- IF SO SET STAT TO 1
  22537. C
  22538.       IF ((KK .EQ. LEN2) .AND. (J .EQ. MATLEN)
  22539.      X      .AND. (DONE .EQ. 1)) STAT = 1
  22540.       CALL SELPUT (BUFFER(TUPLE),ATTYPE,10,NC,LINE)
  22541.       NC = NC + 11
  22542. C
  22543. C             MAKE SURE NO DANGLING PARENS WITHOUT PLUS SIGN
  22544. C
  22545.       IF ((STAT .EQ. 1) .AND. (NC .GE. 60) .AND.
  22546.      X ((ATTSTR .EQ. KZVEC) .OR. (ATTSTR .EQ. KZMAT)))  STAT = 0
  22547.       IF (NC .GE. 60) CALL WRLINE (NC,STAT,LINE)
  22548.       TUPLE = TUPLE + STEP
  22549.   330 CONTINUE
  22550.       IF (ATTSTR .NE. KZMAT) GO TO 350
  22551.       CALL STRMOV (K4RPAR,1,2,LINE,NC)
  22552.       NC = NC + 2
  22553.   350 CONTINUE
  22554.       IF ((ATTSTR .EQ. IBLANK) .AND. (LEN2 .EQ. 1)) GO TO 360
  22555.       IF (NC .NE. 2) NC = NC - 1
  22556.       CALL STRMOV (K4RPAR,1,2,LINE,NC)
  22557.       NC = NC + 2
  22558.   360 CONTINUE
  22559.       IF (NC .GE. 60) CALL WRLINE (NC,STAT,LINE)
  22560.   500 CONTINUE
  22561.       IF (NC .NE. 2) CALL WRLINE (NC,1,LINE)
  22562.       STAT = 0
  22563.   600 CONTINUE
  22564. C
  22565. C  WRITE END STATEMENT FOR RELATION
  22566. C
  22567.       WRITE (NOUTR,700)
  22568.   700 FORMAT (1X,3HEND)
  22569.       GO TO 75
  22570.   800 CONTINUE
  22571.       RMSTAT = 0
  22572.       RETURN
  22573.       END
  22574.       SUBROUTINE UNDEF (ALL,IRCNTR,IDAY,WORD1,LHASH,NAMOWN,NAMDB)
  22575.         Include TEXT.BLK
  22576. C
  22577. C  PURPOSE:  UNLOADS THE DEFINITION OF A DATABASE.
  22578. C
  22579. C  INPUTS:
  22580. C          ALL------------TRUE IF ALL RELATIONS ARE SPECIFIED.
  22581. C          IRCNTR---------NUMBER OF RELATIONS IF SPECIFIED (ALL IS FALSE
  22582. C          IDAY-----------DAY CODE FOR HASH.
  22583. C          WORD1-----------COMMAND SPECIFIED.
  22584. C
  22585.         Include RMATTS.BLK
  22586.         Include RMKEYW.BLK
  22587.         Include CONST4.BLK
  22588.         Include DCLAR2.BLK
  22589.         Include DCLAR6.BLK
  22590.         Include FILES.BLK
  22591.         Include MISC.BLK
  22592.         Include BUFFER.BLK
  22593.         Include FLAGS.BLK
  22594.         Include TUPLEA.BLK
  22595.         Include TUPLER.BLK
  22596.         Include DCLAR1.BLK
  22597.         Include DCLAR3.BLK
  22598.       LOGICAL ALL,PERM,LHASH
  22599. C
  22600. C
  22601.       REAL*8 IREL(100),ATREL(2000)
  22602.       INTEGER STRUC,TYPE,WITH
  22603.       EQUIVALENCE (BUFFER(1),IREL(1)),(BUFFER(201),ATREL(1))
  22604.       DIMENSION LINE(20)
  22605.       IACNTR = 0
  22606.       CALL FILCH (LINE,1,80,IBLANK)
  22607.       WRITE (NOUTR,3) NAMDB
  22608.     3 FORMAT (1X,7HDEFINE ,A6)
  22609.       CALL STRMOV(KWOWNE,1,5,LINE,2)
  22610.       CALL PUTT(LINE,8,K4QUOT)
  22611.       NUM = 17
  22612.       IF (LHASH) NUM = 25
  22613.       IF (LHASH) CALL HASHIN (USERID,IDAY,LINE,9)
  22614.       IF (.NOT. LHASH) CALL STRMOV (USERID,1,8,LINE,9)
  22615.       CALL PUTT (LINE,NUM,K4QUOT)
  22616.       CALL SPOUT (LINE,NUM)
  22617.       WRITE (NOUTR,4)
  22618.     4 FORMAT (1X,10HATTRIBUTES)
  22619. C
  22620. C  PROCESS ATTRIBUTES
  22621. C
  22622.       I = 0
  22623.       IF (IRCNTR .EQ. ALL9S) IRCNTR = 0
  22624.       J = LOCREL(BLANK)
  22625.     5 CONTINUE
  22626.       IF (ALL) GO TO 7
  22627.       I = I + 1
  22628.       IF (I .GT. IRCNTR) GO TO 50
  22629.       K = LOCATT (BLANK,IREL(I))
  22630.       GO TO 10
  22631.     7 CONTINUE
  22632.       CALL CHKREL(PERM,WORD1,ISTAT,NAMOWN)
  22633.       IF (ISTAT .NE. 0) GO TO 50
  22634.       IF (.NOT. PERM)  GO TO 7
  22635.       IRCNTR = IRCNTR + 1
  22636.       K = LOCATT (BLANK,NAME)
  22637.    10 CONTINUE
  22638.       CALL ATTGET (ISTAT)
  22639.       IF (ISTAT .NE. 0) GO TO 5
  22640.       IF (IACNTR .EQ. 0) GO TO 20
  22641.       DO 15 L = 1,IACNTR
  22642.       IF (ATTNAM .EQ. ATREL(L)) GO TO 10
  22643.    15 CONTINUE
  22644. C
  22645. C  NEW ATTRIBUTE
  22646. C
  22647.    20 CONTINUE
  22648.       IACNTR = IACNTR + 1
  22649.       ATREL(IACNTR) = ATTNAM
  22650.       CALL TYPER (ATTYPE,STRUC,TYPE)
  22651.       DO 22 KK = 1,4
  22652.    22 LINE(KK) = IBLANK
  22653.       IF (ATTKEY .NE. 0) LINE (4) = K4KEY
  22654.       IF (ATTWDS .EQ. 0) LINE (3) = KZVAR
  22655.       IF ((TYPE .NE. KZTEXT) .OR. (ATTWDS .EQ. 0)) GO TO 25
  22656.       ATTWDS = ATTCHA
  22657.       IF(ATTCHA.EQ.1) CALL PUTT(LINE(3),4,K41)
  22658.    25 CONTINUE
  22659.       IF (TYPE .EQ. KZDOUB) ATTWDS = ATTWDS/2
  22660.       IF ((ATTWDS .NE. 0) .AND. (ATTWDS .NE. ATTCHA) .AND.
  22661.      X           (STRUC .NE. IBLANK)) ATTWDS = ATTWDS/ATTCHA
  22662.       IF ((STRUC .NE. IBLANK) .AND. (ATTWDS .NE. 0))
  22663.      X              CALL ITOC (LINE(3),1,4,ATTWDS,IERR)
  22664.       IF ((STRUC .EQ. IBLANK) .AND. (ATTWDS .GT. 1))
  22665.      X              CALL ITOC (LINE(3),1,4,ATTWDS,IERR)
  22666.       IF (STRUC .NE. KZMAT) GO TO 40
  22667.       IF (ATTCHA .NE. 0) CALL ITOC (LINE(1),1,4,ATTCHA,IERR)
  22668.       LINE(2) = K4COMA
  22669.       IF (ATTCHA .EQ. 0) LINE(1) = KZVAR
  22670.    40 CONTINUE
  22671.       WRITE (NOUTR,45) ATTNAM,ATTYPE,(LINE(IN),IN=1,4)
  22672.    45 FORMAT (1X,A8,2X,A4,2X,A4,A1,A4,2X,A3)
  22673.       GO TO 10
  22674. C
  22675. C
  22676.    50 CONTINUE
  22677.       IF (IRCNTR .EQ. 0) GO TO 400
  22678.       J = LOCREL(BLANK)
  22679.       WRITE (NOUTR,80)
  22680.    80 FORMAT (1X,9HRELATIONS)
  22681. C
  22682. C  LOOP THROUGH AND PRINT THE RELATIONS WITH THEIR ATTRIBUTES
  22683. C
  22684.       DO 150 I = 1,IRCNTR
  22685.       IF (ALL) GO TO 90
  22686.       RNAME = IREL(I)
  22687.       J = LOCREL (RNAME)
  22688.       CALL RELGET (ISTAT)
  22689.       GO TO 95
  22690.    90 CONTINUE
  22691.       CALL CHKREL (PERM,WORD1,ISTAT,NAMOWN)
  22692.       IF (ISTAT .NE. 0) GO TO 150
  22693.       IF (.NOT. PERM) GO TO 90
  22694.       RNAME = NAME
  22695.    95 CONTINUE
  22696.       ICUM = 0
  22697.       ICOUNT = 1
  22698.       NAMES (1) = RNAME
  22699.       WITH = K4WITH
  22700.       IEND = K4PLUS
  22701.       J = LOCATT (BLANK,RNAME)
  22702.   100 CONTINUE
  22703.       CALL ATTGET (ISTAT)
  22704.       IF (ISTAT .NE. 0) GO TO 105
  22705.       ICOUNT = ICOUNT + 1
  22706.       ICUM = ICUM + 1
  22707.       NAMES (ICOUNT) = ATTNAM
  22708.       IF (ICOUNT .LT. 5) GO TO 100
  22709.   105 IF (ICUM .EQ. NATT) IEND = IBLANK
  22710.       IF (ICOUNT .NE. 1) WRITE (NOUTR,110) NAMES(1),WITH,
  22711.      X         (NAMES(KK),KK=2,ICOUNT),IEND
  22712.   110 FORMAT (1X,A8,1X,A4,1X,5(A8,1X))
  22713.       NAMES(1) = BLANK
  22714.       WITH = IBLANK
  22715.       ICOUNT = 1
  22716.       IF (ISTAT .EQ. 0) GO TO 100
  22717.   150 CONTINUE
  22718. C
  22719. C  PRINT PASSWORDS (HASHED)
  22720. C
  22721.       WRITE (NOUTR,175)
  22722.   175 FORMAT (1X,9HPASSWORDS)
  22723.       CALL FILCH (LINE,1,80,IBLANK)
  22724.       J = LOCREL (BLANK)
  22725.       DO 300 I = 1,IRCNTR
  22726.       IF (ALL) GO TO 225
  22727.       J = LOCREL (IREL(I))
  22728.       RNAME = IREL(I)
  22729.       GO TO 240
  22730.   225 CONTINUE
  22731.       CALL CHKREL (PERM,WORD1,ISTAT,NAMOWN)
  22732.       IF (.NOT. PERM) GO TO 225
  22733.       RNAME = NAME
  22734.   240 CONTINUE
  22735.       CALL STRMOV(KWRPW,1,3,LINE,2)
  22736.       CALL STRMOV(K4FOR,1,3,LINE,6)
  22737.       CALL STRMOV (RNAME,1,8,LINE,10)
  22738.       CALL STRMOV(K4IS,1,2,LINE,19)
  22739.       CALL PUTT(LINE,22,K4QUOT)
  22740.       NUM = 31
  22741.       IF (LHASH) NUM = 39
  22742.       CALL PUTT (LINE,NUM,K4QUOT)
  22743.       RPW1 = RPW
  22744.       DO 250 J = 1,2
  22745.       IF (RPW1 .EQ. K4NONE) GO TO 230
  22746.       IF (LHASH) CALL HASHIN (RPW1,IDAY,LINE,23)
  22747.       IF (.NOT. LHASH) CALL STRMOV (RPW1,1,8,LINE,23)
  22748.       CALL SPOUT (LINE,NUM)
  22749.   230 CONTINUE
  22750.       RPW1 = MPW
  22751.       CALL PUTT (LINE,2,K4M)
  22752.   250 CONTINUE
  22753.   300 CONTINUE
  22754.   400 CONTINUE
  22755.       WRITE (NOUTR,450)
  22756.   450 FORMAT (1X,3HEND)
  22757.       RETURN
  22758.       END
  22759.       SUBROUTINE UNLOAD
  22760.         Include TEXT.BLK
  22761. C
  22762. C  PURPOSE:  SUBROUTINE CHECKS SYNTAX ON UNLOAD COMMAND AND UNLOADS
  22763. C            ACCORDING TO WHAT THE USER SPECIFIED.  CALLS UNDATA AND
  22764. C            UNDEF TO ACCOMPLISH THIS PURPOSE.
  22765. C
  22766. C
  22767.         Include CONST4.BLK
  22768.         Include CONST8.BLK
  22769.         Include FILES.BLK
  22770.         Include BUFFER.BLK
  22771.         Include FLAGS.BLK
  22772.         Include RIMCOM.BLK
  22773.         Include TUPLER.BLK
  22774.         Include DCLAR1.BLK
  22775.         Include DCLAR2.BLK
  22776.         Include DCLAR3.BLK
  22777.         Include DCLAR6.BLK
  22778.         Include MISC.BLK
  22779.       REAL*8 IREL(100)
  22780.       INTEGER CHAR1,CHAR2
  22781.       EQUIVALENCE (BUFFER(1),IREL(1))
  22782.       LOGICAL ALL,PERM,LHASH
  22783.       DIMENSION NUMBER(9)
  22784.       EQUIVALENCE (NUMBER(1),K41)
  22785.       DATA NAMES /10*0/
  22786.       DATA NWORDS /2500/
  22787.       NAMES(1) = K8SCH
  22788.       NAMES(2) = K8ALL
  22789.       NAMES(3) = K8DATA
  22790.       LHASH = .FALSE.
  22791.       NOGO = 0
  22792. C
  22793. C  CLEAR OUT ANY PAGE DATA LEFT IN BUFFER
  22794. C
  22795.       CALL BLKCLN
  22796.       RMSTAT = 0
  22797.       ALL = .TRUE.
  22798.       WORD1 = K8ALL
  22799.       NUM = 2
  22800.       NAMOWN = USERID
  22801.       NAMDB = DBNAME
  22802.       ITEMS = LXITEM (I)
  22803. C
  22804. C  CHECK TO SEE IF DEFAULTS
  22805. C
  22806.       IF (ITEMS .EQ. 1) GO TO 25
  22807. C
  22808. C  FIND OUT IF WANT ALL,SCHEMA, OR DATA
  22809. C
  22810. C  SAVE THE PARTICULAR UNLOAD COMMAND IN WORD1
  22811. C
  22812.       WORD2 = BLANK
  22813.       CALL LXSREC (2,1,8,WORD2,1)
  22814.       DO 5 I = 1,3
  22815.       IF (NAMES (I) .NE. WORD2) GO TO 5
  22816.       WORD1 = WORD2
  22817.       GO TO 20
  22818.     5 CONTINUE
  22819. C
  22820. C  CHECK FOR DATA BASE NAME
  22821. C
  22822.       NAMDB = WORD2
  22823.       IF (NAMDB .NE. DBNAME) GO TO 9000
  22824. C
  22825. C  CHECK TO SEE IF DEFAULTS TO ALL
  22826. C
  22827.       IF (ITEMS .EQ. 2) GO TO 20
  22828.       NUM = NUM + 1
  22829. C
  22830. C  CHECK TO SEE IF WANTS TO CHANGE THE DBNAME
  22831. C
  22832. C
  22833.       IF (LXWREC (3,1) .NE. K4EQS) GO TO 15
  22834.       IF (ITEMS .EQ. 3) GO TO 9000
  22835. C
  22836. C  CHANGE THE NAME
  22837. C
  22838.       NAMDB = BLANK
  22839.       CALL LXSREC (4,1,6,NAMDB,1)
  22840.       NUM = NUM + 2
  22841. C
  22842. C  CHECK TO SEE IF JUST DEFAULT TO ALL
  22843. C
  22844.       IF (ITEMS .LE. 4) GO TO 20
  22845.    15 CONTINUE
  22846.       WORD1 = BLANK
  22847.       CALL LXSREC (NUM,1,8,WORD1,1)
  22848. C
  22849. C  CHECK TO SEE IF VALID COMMAND
  22850. C
  22851.       IF ((WORD1 .NE. K8ALL) .AND. (WORD1 .NE. K8SCH) .AND.
  22852.      X      (WORD1 .NE. K8DATA)) GO TO 9000
  22853. C
  22854. C
  22855.   20  CONTINUE
  22856. C
  22857. C  CHECK FOR HASH
  22858. C
  22859.       IF (NUM .EQ. ITEMS) GO TO 25
  22860.       IF (LXWREC(NUM + 1,1) .NE. K4EQS) GO TO 25
  22861.       IF (NUM + 1 .EQ. ITEMS) GO TO 9000
  22862.       IF (LXWREC(NUM + 2,1) .NE. K4HASH) GO TO 9000
  22863.       LHASH = .TRUE.
  22864.       NUM = NUM + 2
  22865.    25 CONTINUE
  22866.       ICNTR = 0
  22867.       CALL BLKDEF (10,NWORDS,1)
  22868.       IPERM = 0
  22869.   100 CONTINUE
  22870.       IF (ITEMS .GT. NUM) GO TO 200
  22871. C
  22872. C  THE COMMAND IS ALL SO SET ICNTR TO MAX
  22873. C
  22874.       ICNTR = ALL9S
  22875.       GO TO 400
  22876. C
  22877. C  THE USER HAS SPECIFIED WHICH RELATIONS HE WANTS DUMPED
  22878. C
  22879.   200 CONTINUE
  22880.       J = NUM + 1
  22881.       ALL = .FALSE.
  22882.   210 CONTINUE
  22883.       RNAME = BLANK
  22884.       CALL LXSREC (J,1,8,RNAME,1)
  22885.       IERR = 0
  22886.       IN = LOCREL (RNAME)
  22887.       IF (IN .EQ. 0) GO TO 225
  22888.       WRITE (NOUT,215) RNAME
  22889.   215 FORMAT (/,2X,34H--ERROR-- INCORRECT RELATION NAME ,A8,/)
  22890.       RMSTAT = 2
  22891.       IERR = 1
  22892.   225 CONTINUE
  22893.       IF ((J + 1) .GT. ITEMS) GO TO 250
  22894.       RNAME1 = BLANK
  22895.       CALL LXSREC (J+1,1,8,RNAME1,1)
  22896.       IF (RNAME1 .NE. K4EQS) GO TO 250
  22897. C
  22898. C  CHECK FOR INCORRECT SYNTAX
  22899. C
  22900.       IF ((J + 2) .GT. ITEMS) GO TO 9000
  22901.       J = J + 2
  22902.       IF (IERR .EQ. 1) GO TO 350
  22903. C
  22904. C  CHECK FOR PASSWORD
  22905. C
  22906.       NAMOWN = BLANK
  22907.       CALL LXSREC (J,1,8,NAMOWN,1)
  22908.   250 CONTINUE
  22909. C
  22910. C
  22911. C  CALL CHKREL TO CHECK PASSWORD PERMISSION ON THE UNLOAD
  22912. C
  22913.       CALL CHKREL (PERM,WORD1,ISTAT,NAMOWN)
  22914.       IF (PERM) GO TO 300
  22915.       WRITE (NOUT,275) RNAME
  22916.   275 FORMAT (/,2X,43H--ERROR-- YOU ARE NOT AUTHORIZED TO UNLOAD ,A8,/)
  22917.       RMSTAT = 9
  22918.       IERR = 1
  22919.       GO TO 350
  22920.   300 CONTINUE
  22921. C
  22922. C  CHECK TO MAKE SURE THERE IS ONLY ONE OF THE RELATIONS LISTED
  22923. C
  22924.       IF (ICNTR .EQ. 0 ) GO TO 335
  22925.       DO 310 KK = 1,ICNTR
  22926.       IF (IREL(ICNTR) .EQ. RNAME) GO TO 325
  22927.   310 CONTINUE
  22928.       GO TO 335
  22929.   325 CONTINUE
  22930.       WRITE (NOUT,330) RNAME
  22931.   330 FORMAT (/,2X,39H--WARNING-- YOU HAVE ALREADY SPECIFIED ,
  22932.      X            14HRELATION NAME ,A8)
  22933.       GO TO 350
  22934. C
  22935. C  EVERYTHING IS CORRECT -- SAVE CERTAIN DATA IN IREL(ICNTR)
  22936. C
  22937.   335 CONTINUE
  22938.       ICNTR = ICNTR + 1
  22939.       IREL(ICNTR) = NAME
  22940.   350 CONTINUE
  22941.       J = J + 1
  22942.       IF (IERR .EQ. 1) NOGO = 1
  22943.       IF ( J .LE. ITEMS) GO TO 210
  22944. C
  22945. C  DONE WITH PERMISSION AND CRACKING
  22946. C
  22947.   400 CONTINUE
  22948.       IF (NOGO .EQ. 1) GO TO 9999
  22949.       WRITE(NOUTR,425)
  22950.   425 FORMAT(16H*(SET SEMI=NULL),/,18H*(SET DOLLAR=NULL))
  22951.       IF (.NOT. LHASH) GO TO 480
  22952.       CALL RMDATE (IDAY)
  22953.       CALL RMTIME (ITIME)
  22954.       WRITE (NOUTR,450) ITIME,IDAY
  22955.   450 FORMAT (24H RIM COMMUNICATION FILE ,2A10)
  22956. C
  22957. C  CHANGE DAY DATE TO INTEGER
  22958. C
  22959.       CALL GETT (IDAY,8,CHAR1)
  22960.       CALL GETT (IDAY,7,CHAR2)
  22961.       DO 475 KK=1,9
  22962.       IF (CHAR1 .EQ. NUMBER (KK)) CHAR1 = KK
  22963.       IF (CHAR2 .EQ. NUMBER (KK)) CHAR2 = KK
  22964.   475 CONTINUE
  22965.  
  22966.       IF(CHAR1.EQ.K40) CHAR1 = 0
  22967.       IF((CHAR2.EQ.K40).OR.(CHAR2.EQ.IBLANK)) CHAR2 = 0
  22968.       NUM = CHAR2 * 10 + CHAR1
  22969.       NUM = MOD (NUM,7)
  22970. C
  22971. C  IF DIRECTIVE ALL OR SCHEMA CALL UNDEF
  22972. C
  22973.   480 CONTINUE
  22974.       IF ((WORD1 .EQ. K8SCH) .OR. (WORD1 .EQ. K8ALL))
  22975.      X             CALL UNDEF (ALL,ICNTR,NUM,WORD1,LHASH,NAMOWN,NAMDB)
  22976.       IF (ICNTR .EQ. 0) GO TO 8000
  22977.       IF ((WORD1 .EQ. K8ALL) .OR. (WORD1 .EQ. K8DATA))
  22978.      X             CALL UNDATA (ALL,ICNTR,NUM,WORD1,LHASH,NAMOWN)
  22979.       IF (ICNTR .EQ. 0) GO TO 8000
  22980.       WRITE(NOUTR,490)
  22981.   490 FORMAT(13H*(SET SEMI=;),/,15H*(SET DOLLAR=$))
  22982.       GO TO 9999
  22983.  8000 CONTINUE
  22984. C
  22985. C  ERROR FOR UNLOADING ALL OF THE DATA
  22986. C
  22987.       WRITE (NOUT,8001)
  22988.  8001 FORMAT (/,2X,39H--ERROR-- YOU DO NOT HAVE AUTHORIZATION,
  22989.      X        /,13X,26HTO UNLOAD ALL OF THE DATA.,/)
  22990.       RMSTAT = 9
  22991.       GO TO 9999
  22992. C
  22993. C  INCORRECT SYNTAX ERROR MESSAGE
  22994. C
  22995.  9000 CONTINUE
  22996.       WRITE (NOUT,9001)
  22997.  9001 FORMAT (/,2X,42H--ERROR-- INCORRECT SYNTAX FOR THE COMMAND,/)
  22998.       RMSTAT = 4
  22999. C
  23000. C  CLEAN UP AND END
  23001. C
  23002.  9999 CONTINUE
  23003.       CALL BLKCLR (10)
  23004.       RETURN
  23005.       END
  23006. c        interface to integer*2 function system [c]
  23007. c     +          (string[reference])
  23008. c        character*1 string
  23009. c        end
  23010.     SUBROUTINE USRCMD(CMDLIN,IGOTIT)
  23011.     Include dos.inc
  23012.     Logical*4 success,amiga
  23013.     CHARACTER*1 CMDLIN(80)
  23014.     CHARACTER*81 CMDSTR
  23015.     CHARACTER*1 CMLN(80),CMLN2(84)
  23016.     Integer inp,outp
  23017. c    INTEGER*2 SYSTEM
  23018.     EXTERNAL SYSTEM
  23019.     EQUIVALENCE(CMLN,CMDSTR)
  23020.     EQUIVALENCE(CMLN2(5),CMLN(1))
  23021. C
  23022. C IF INITIAL CHARACTER IS $ THEN EXEC A NEW PROCESS UNDER MSDOS
  23023. C TO GIVE A BIT MORE FLEXIBILITY DURING RIM OPERATION.
  23024. C
  23025. C INSERT CODE FOR ADDING A LIB$SPAWN CALL HERE TO PASS COMMANDS TO
  23026. C DOS IF THEY BEGIN WITH A } CHARACTER.
  23027.     IGOTIT=0
  23028.     IF(CMDLIN(1).NE.'}')GOTO 9990
  23029. C
  23030. CC HERE CALL EXECIT WITH THE COMMAND LINE AS AN ARGUMENT...
  23031.     DO 1000 NN=1,79
  23032. 1000    CMLN(NN)=CMDLIN(NN+1)
  23033.     CMLN(79)=Char(13)
  23034.     CMLN(80)=Char(0)
  23035.     DO 1002 NN=1,77
  23036.     N=78-NN
  23037.     IF(ICHAR(CMLN(N)).GT.32)GOTO 1004
  23038. 1002    CONTINUE
  23039. C FINDING END OF REAL STRING THIS WAY
  23040. 1004    CONTINUE
  23041.     CMLN(N+1)=Char(0)
  23042. C ADD C.R., THEN NULL
  23043.     CMLN(N+2)=Char(0)
  23044.     CMLN(N+3)=Char(0)
  23045. C INSERT LENGTH COUNT AS 1ST BYTE OF CMD LENGTH
  23046. C PER DOS 2.0 MANUAL PG F-1
  23047. c    CMLN2(1)=CHAR(N+3)
  23048. c    CMLN2(2)='/'
  23049. c    CMLN2(3)='C'
  23050. c    CMLN2(4)=' '
  23051. CC ! ADD C.R. AFTER LINE
  23052. CC ABOVE, INSERT A CR AFTER CMD LINE
  23053.     inp=0
  23054.     outp=0
  23055.     success=amiga(Execute,cmln2(5),inp,outp)
  23056. c    N=SYSTEM(CMLN2(5))
  23057. 2300    CONTINUE
  23058.     IGOTIT=1
  23059. 9990    CONTINUE
  23060.     RETURN
  23061.     END
  23062.       SUBROUTINE LOWER(I,LOW)
  23063.       CHARACTER*1 I,LOW
  23064.       CHARACTER*1 TABLE(2,26)
  23065.       DATA TABLE /'A','a','B','b','C','c','D','d','E','e'
  23066.      x,'F','f','G','g','H','h','I','i','J','j','K','k','L','l'
  23067.      x,'M','m','N','n','O','o','P','p','Q','q','R','r','S','s'
  23068.      x,'T','t','U','u','V','v','W','w','X','x','Y','y','Z','z'/
  23069.       DO 100 J=1,26
  23070.       IF(TABLE(1,J).EQ.I) LOW = TABLE(2,J)
  23071.   100 CONTINUE
  23072.       RETURN
  23073.       END
  23074.       SUBROUTINE WARN(NUM,WORD1,WORD2)
  23075.         Include TEXT.BLK
  23076. C
  23077. C  PURPOSE:   GENERAL PURPOSE WARNING PRINT ROUTINE
  23078. C
  23079. C  PARAMETERS:
  23080. C     INPUT:  NUM-----WARNING NUMBER
  23081. C             WORD1----OPTIONAL NAME
  23082. C             WORD2----OPTIONAL NAME
  23083. C
  23084.         Include CONST8.BLK
  23085.         Include FILES.BLK
  23086.         Include DCLAR6.BLK
  23087. C
  23088.       IF(NUM.NE.1) GO TO 2
  23089.       WRITE (NOUT,100) WORD1
  23090.   100 FORMAT(9H -ERROR- ,A8,
  23091.      X      34H IS NOT A RECOGNIZED RELATION NAME )
  23092.       GO TO 99
  23093. C
  23094.     2 IF(NUM.NE.2) GO TO 3
  23095.       WRITE (NOUT,200)
  23096.   200 FORMAT(27H -ERROR- UNDEFINED RELATION )
  23097.       GO TO 99
  23098. C
  23099.     3 IF(NUM.NE.3) GO TO 4
  23100.       WRITE (NOUT,300) WORD1,WORD2
  23101.   300 FORMAT(19H -ERROR- ATTRIBUTE ,A8,
  23102.      X       24H IS NOT IN THE RELATION ,A8)
  23103.       GO TO 99
  23104. C
  23105.     4 IF(NUM.NE.4) GO TO 5
  23106.       WRITE (NOUT,400)
  23107.   400 FORMAT(45H -ERROR- SYNTAX IS INCORRECT FOR THE COMMAND )
  23108.       GO TO 99
  23109. C
  23110.     5 IF(NUM.NE.5) GO TO 6
  23111.       WRITE (NOUT,500)
  23112.   500 FORMAT(49H -ERROR- SYNTAX IS INCORRECT FOR THE WHERE CLAUSE )
  23113.       GO TO 99
  23114. C
  23115.     6 IF(NUM.NE.6) GO TO 7
  23116.       WRITE (NOUT,600)
  23117.   600 FORMAT(/,/,41H COMMAND TERMINATED - ENTER NEXT COMMAND ,/)
  23118.       CALL SETIN(K8IN)
  23119.       GO TO 99
  23120. C
  23121.     7 IF(NUM.NE.7) GO TO 8
  23122.       WRITE (NOUT,700) WORD1,WORD2
  23123.   700 FORMAT(9H -ERROR- ,A8,A1,
  23124.      X      34H NAMES MAY NOT EXCEED 8 CHARACTERS  )
  23125.       GO TO 99
  23126. C
  23127.     8 IF(NUM.NE.8) GO TO 9
  23128.       GO TO 99
  23129. C
  23130.     9 IF(NUM.NE.9) GO TO 10
  23131.       WRITE(NOUT,900) WORD1
  23132.   900 FORMAT(41H -ERROR- UNAUTHORIZED ACCESS TO RELATION ,A8)
  23133.       GO TO 99
  23134. C
  23135.    10 IF(NUM.NE.10) GO TO 11
  23136.       WRITE (NOUT,1000)
  23137.  1000 FORMAT(50H -ERROR- DATA FILES DO NOT CONTAIN A RIM DATA BASE)
  23138.       GO TO 99
  23139. C
  23140.    11 IF(NUM.NE.11) GO TO 12
  23141.       WRITE (NOUT,1100)
  23142.  1100 FORMAT(52H -ERROR- DATA BASE NAME DOES NOT MATCH FILE CONTENTS)
  23143.       GO TO 99
  23144. C
  23145.    12 IF(NUM.NE.12) GO TO 13
  23146.       WRITE(NOUT,1200) WORD1
  23147.  1200 FORMAT(13H -ERROR- THE ,A7,32H DATABASE FILES ARE INCOMPATIBLE)
  23148.       GO TO 99
  23149. C
  23150.    13 IF(NUM.NE.13) GO TO 14
  23151.       WRITE(NOUT,1300) WORD1
  23152.  1300 FORMAT(/,1X,12H-ERROR- THE ,A7,25H DATABASE IS ATTACHED IN ,
  23153.      1            14HREAD ONLY MODE,/)
  23154.       GO TO 99
  23155. C
  23156.    14 IF(NUM.NE.14) GO TO 15
  23157.       WRITE(NOUT,1400) WORD1
  23158.  1400 FORMAT(/,1X, 4HTHE ,A7,29H DATABASE IS BEING UPDATED - ,
  23159.      1            16HPLEASE TRY LATER,/)
  23160.       GO TO 99
  23161. C
  23162.    15 IF(NUM.NE.15) GO TO 16
  23163.       WRITE(NOUT,1500) WORD1
  23164.  1500 FORMAT(18H -ERROR- DATABASE ,A7,20H IS NOT A LOCAL FILE )
  23165.       GO TO 99
  23166. C
  23167.    16 CONTINUE
  23168.    99 RETURN
  23169.       END
  23170.       SUBROUTINE WHERE(IS)
  23171.         Include TEXT.BLK
  23172. C
  23173. C  PURPOSE:  PROCESS A RIM WHERE CLAUSE
  23174. C
  23175. C  PARAMETERS:
  23176. C         IS------POINTER TO WHERE IN IREC ARRAY
  23177.         Include RMATTS.BLK
  23178.         Include RMKEYW.BLK
  23179.         Include CONST4.BLK
  23180.         Include MISC.BLK
  23181.         Include RIMCOM.BLK
  23182.         Include TUPLEA.BLK
  23183.         Include TUPLER.BLK
  23184.         Include WHCOM.BLK
  23185.         Include FILES.BLK
  23186.         Include RIMPTR.BLK
  23187. C
  23188.       LOGICAL EQKEYW
  23189.       LOGICAL IFLIM
  23190.       LOGICAL IFTUP
  23191.         Include DCLAR1.BLK
  23192.       NS = 0
  23193.       NTUPC = 0
  23194.       KMM = 0
  23195.       KSTRT = 0
  23196.       MAXTU = 0
  23197.       LIMTU = ALL9S
  23198.       ITEMS = LXITEM(ITEMP)
  23199.       JE = ITEMS - IS
  23200.       IF(JE.LT.2) GO TO 7000
  23201. C
  23202. C  BREAK UP EACH CONDITION.
  23203. C
  23204.       DO 600 I=1,10
  23205.       KOMPOS(I) = 0
  23206.       KOMPOT(I) = 0
  23207.       KOMLEN(I) = 0
  23208.       KATTP(I) = 0
  23209.       KATTL(I) = 0
  23210.       KATTY(I) = 0
  23211.   600 CONTINUE
  23212.       RMSTAT = 0
  23213.       NBOO = 1
  23214.       BOO(1) = K4AND
  23215.       NEXPOT = 1
  23216.       NEXPOS = 1
  23217.  1000 CONTINUE
  23218.       IS = IS + 1
  23219.       IF(IS.GT.ITEMS) GO TO 2000
  23220. C
  23221. C  GET THE ATTRIBUTE.
  23222. C
  23223.       IFLIM = .FALSE.
  23224.       IF(.NOT.EQKEYW(IS,KWLIMI,5)) GO TO 1150
  23225. C
  23226. C     LIMIT KEYWORD
  23227. C
  23228.       IF(.NOT.EQKEYW(IS+1,KWEQ,2)) GO TO 7100
  23229.       IF(LXID(IS+2).NE.KZINT) GO TO 7200
  23230.       LIMTU = LXIREC(IS+2)
  23231.       IF(LIMTU.LE.0) GO TO 7200
  23232.       NBOO = NBOO - 1
  23233.       IFLIM = .TRUE.
  23234.       GO TO 1800
  23235.  1150 CONTINUE
  23236.       IF(NBOO.LE.10) GO TO 1160
  23237. C
  23238. C  TOO MANY CONDITIONS.
  23239. C
  23240.       WRITE(NOUT,9002)
  23241.  9002 FORMAT(52H -ERROR- MORE THAN 10 CONDITIONS IN THE WHERE CLAUSE)
  23242.       GO TO 8000
  23243.  1160 CONTINUE
  23244.       IFTUP = EQKEYW(IS,KWROWS,4)
  23245.       IF(.NOT.IFTUP) GO TO 1190
  23246. C
  23247. C  ROW WHERE CLAUSE - CHECK TYPE AND GET MAXIMUM ROW NUMBER
  23248. C
  23249.       NTUPC = NTUPC + 1
  23250.       IF(LXID(IS+2).NE.KZINT) GO TO 7300
  23251.       MAXTUN = LXIREC(IS+2)
  23252.       IF(MAXTUN.LE.0) GO TO 7300
  23253.       IF(MAXTUN.GT.MAXTU) MAXTU = MAXTUN
  23254.       KOMPAR = IBLANK
  23255.       CALL LXSREC(IS+1,1,3,KOMPAR,1)
  23256.       KOMTYP(NBOO) = LOCBOO(KOMPAR)
  23257.       IF(KOMTYP(NBOO).NE.0) GO TO 1170
  23258. C
  23259. C  UNRECOGNIZED BOOLEAN COMPARISION.
  23260. C
  23261.       WRITE(NOUT,9003) KOMPAR
  23262.       GO TO 8000
  23263.  1170 CONTINUE
  23264.       IF((KOMTYP(NBOO).GE.3).AND.(KOMTYP(NBOO).LE.5)) MAXTU = NTUPLE
  23265.       GO TO 1500
  23266.  1190 ANAME = BLANK
  23267.       CALL LXSREC(IS,1,8,ANAME,1)
  23268.       I = LOCATT(ANAME,NAME)
  23269.       IF(I.NE.0) GO TO 1200
  23270.       CALL ATTGET(I)
  23271.       IF(I.EQ.0) GO TO 1300
  23272. C
  23273. C  UNRECOGNIZED ATTRIBUTE.
  23274. C
  23275.  1200 CONTINUE
  23276.       CALL WARN(3,ANAME,NAME)
  23277.       GO TO 8000
  23278.  1300 CONTINUE
  23279.       KATTP(NBOO) = ATTCOL
  23280.       KATTL(NBOO) = ATTLEN
  23281.       CALL TYPER(ATTYPE,MATVEC,KATTY(NBOO))
  23282. C
  23283. C  DETERMINE THE TYPE OF BOOLEAN EXPRESSION.
  23284. C
  23285.       KOMPAR = IBLANK
  23286.       CALL LXSREC(IS+1,1,3,KOMPAR,1)
  23287.       KOMTYP(NBOO) = LOCBOO(KOMPAR)
  23288.       IF(KOMTYP(NBOO).NE.0) GO TO 1500
  23289. C
  23290. C  UNRECOGNIZED BOOLEAN COMPARISION.
  23291. C
  23292.       WRITE(NOUT,9003) KOMPAR
  23293.  9003 FORMAT(9H -ERROR- ,A4,34H IS NOT A VALID BOOLEAN COMPARISON)
  23294.       GO TO 8000
  23295.  1500 CONTINUE
  23296. C
  23297. C  CHECK FOR FAILS OR EXISTS
  23298. C
  23299.       IF(KOMTYP(NBOO).LE.1) GO TO 1800
  23300.       IF(KOMTYP(NBOO).GE.10) GO TO 1600
  23301. C
  23302. C     CHECK FOR "WHERE XXX EQ MIN OR MAX"
  23303. C
  23304.       ITEMP = LXWREC(IS+2,1)
  23305.       KMM = 0
  23306.       IF((ITEMP.EQ.K4MIN).OR.(ITEMP.EQ.K4MAX)) KMM = ITEMP
  23307.       IF(KMM.EQ.0) GO TO 1550
  23308. C
  23309. C  WE HAVE A MIN/MAX SPECIFICATION - CHECK SYNTAX
  23310. C
  23311.       IF((KOMTYP(NBOO).LT.2).OR.(KOMTYP(NBOO).GT.7)) GO TO 1550
  23312.       IF(ATTYPE.EQ.KZTEXT) GO TO 1550
  23313.       IF(ATTYPE.EQ.KZINT ) GO TO 1530
  23314.       IF(ATTYPE.EQ.KZREAL) GO TO 1530
  23315.       IF(ATTYPE.EQ.KZDOUB) GO TO 1530
  23316. C
  23317. C  ILLEGAL ATTRIBUTE FOR USE WITH MIN/MAX.
  23318. C
  23319.       WRITE(NOUT,9000) ATTYPE
  23320.  9000 FORMAT(9H -ERROR- ,A4,42H ATTRIBUTES CANNOT BE USED WITH MIN OR MA
  23321.      XX)
  23322.       GO TO 8000
  23323.  1530 CONTINUE
  23324.       IF(ATTLEN.EQ.1) GO TO 1540
  23325.       IF((ATTLEN.EQ.2).AND.(ATTYPE.EQ.KZDOUB)) GO TO 1540
  23326. C
  23327. C  ILLEGAL USE OF MULTI-WORD ATTRIBUTE WITH MIN/MAX.
  23328. C
  23329.       WRITE(NOUT,9001)
  23330.  9001 FORMAT(61H -ERROR- MULTI-WORD ATTRIBUTES CANNOT BE USED WITH MIN O
  23331.      XR MAX)
  23332.       GO TO 8000
  23333.  1540 CONTINUE
  23334. C
  23335. C     SET NBOO AND LIMTU TO FOOL RMLOOK FOR MINMAX
  23336. C
  23337.       MNBOO = NBOO
  23338.       MLIMTU = LIMTU
  23339.       NBOO = 0
  23340.       LIMTU = ALL9S
  23341.       KOMPOS(MNBOO) = NEXPOS
  23342.       CALL MINMAX(WHRVAL(NEXPOS),KMM)
  23343.       IF(RMSTAT.NE.0) GO TO 7700
  23344.       NEXPOS = NEXPOS + ATTLEN
  23345.       KOMPOT(MNBOO) = NEXPOT
  23346.       WHRLEN(NEXPOT) = ATTLEN
  23347.       NEXPOT = NEXPOT + 1
  23348.       LIMTU = MLIMTU
  23349.       NBOO = MNBOO
  23350. C
  23351. C  RESET RELATION POINTERS
  23352. C
  23353.       I = LOCREL(NAME)
  23354.       IS = IS + 3
  23355.       KOMLEN(NBOO) = 1
  23356.       IF(IS.GT.ITEMS) GO TO 2100
  23357.       IF((LXWREC(IS,1).NE.K4AND).AND.(LXWREC(IS,1).NE.K4OR)) GO TO 7400
  23358.       NBOO = NBOO + 1
  23359.       BOO(NBOO) = LXWREC(IS,1)
  23360.       GO TO 1000
  23361.  1550 CONTINUE
  23362. C
  23363. C  VALUE COMPARISON. MAKE SURE THE VALUE LOOKS GOOD.
  23364. C
  23365.       NLIST = 0
  23366.       IS = IS + 2
  23367.       CALL ITOH(NR,NW,KATTL(NBOO))
  23368.       IF(KATTY(NBOO).EQ.0) NW = 1
  23369.       ITYPE = ATTYPE
  23370.       IF(KATTY(NBOO).EQ.0) ITYPE = KZINT
  23371.       KOMPOS(NBOO) = NEXPOS
  23372.       KOMPOT(NBOO) = NEXPOT
  23373.       IF(KOMTYP(NBOO).EQ.9) GO TO 1580
  23374.  1560 CONTINUE
  23375. C
  23376. C     USE PARVAL TO EXTRACT NEXT VALUE
  23377. C
  23378.       NWORDS = NW
  23379.       NROW = NR
  23380.       CALL PARVAL(IS,WHRVAL(NEXPOS),ITYPE,NWORDS,NROW,0,IERR)
  23381.       IF(IERR.NE.0) GO TO 8000
  23382.       IF(.NOT.IFTUP) GO TO 1570
  23383. C
  23384. C  ROW WHERE CLAUSE - CHECK TYPE AND SET MAXIMUM ROW
  23385. C
  23386.       IF(WHRVAL(NEXPOS).LE.0) GO TO 7300
  23387.       IF(WHRVAL(NEXPOS).GT.ALL9S) GO TO 7300
  23388.       IF(WHRVAL(NEXPOS).GT.MAXTU) MAXTU = WHRVAL(NEXPOS)
  23389.  1570 CONTINUE
  23390.       NLIST = NLIST + 1
  23391.       NEXPOS = NEXPOS + NWORDS
  23392.       CALL HTOI(NROW,NWORDS,WHRLEN(NEXPOT))
  23393.       NEXPOT = NEXPOT + 1
  23394.       KOMLEN(NBOO) = NLIST
  23395.       IF(NLIST.EQ.1) GO TO 1575
  23396. C
  23397. C  WE HAVE A LIST - VALID ONLY FOR EQ, EQS, AND NE
  23398. C
  23399.       IF((KOMTYP(NBOO).NE.2).AND.(KOMTYP(NBOO).NE.3)) GO TO 7600
  23400.  1575 CONTINUE
  23401.       IF(IS.GT.ITEMS) GO TO 2100
  23402.       IF((LXWREC(IS,1).NE.K4AND).AND.(LXWREC(IS,1).NE.K4OR)) GO TO 1560
  23403.       NBOO = NBOO + 1
  23404.       BOO(NBOO) = LXWREC(IS,1)
  23405.       GO TO 1000
  23406.  1580 CONTINUE
  23407. C
  23408. C     EQS - ONLY SAVE WHATS INPUT
  23409. C
  23410.       IF(ATTYPE.EQ.KZTEXT) GO TO 1585
  23411.  1581 CONTINUE
  23412.       WRITE (NOUT,1582)
  23413.  1582 FORMAT(46H -ERROR- EQS REQUIRES TEXT ELEMENTS AND VALUES )
  23414.       GO TO 8000
  23415.  1585 CONTINUE
  23416.       IF(LXID(IS).NE.KZTEXT) GO TO 1581
  23417.       NW = LXLENW(IS)
  23418.       NR = LXLENC(IS)
  23419.       CALL LXSREC(IS,1,NR,WHRVAL(NEXPOS),1)
  23420.       NEXPOS = NEXPOS + NW
  23421.       IS = IS + 1
  23422.       CALL HTOI(NR,NW,WHRLEN(NEXPOT))
  23423.       NEXPOT = NEXPOT + 1
  23424.       NLIST = NLIST + 1
  23425.       KOMLEN(NBOO) = NLIST
  23426.       IF(IS.GT.ITEMS) GO TO 2100
  23427.       IF((LXWREC(IS,1).NE.K4AND).AND.(LXWREC(IS,1).NE.K4OR)) GO TO 1585
  23428.       NBOO = NBOO + 1
  23429.       BOO(NBOO) = LXWREC(IS,1)
  23430.       GO TO 1000
  23431. C
  23432. C  ATTRIBUTE COMPARISON. CHECK FOR LEGAL ATTRIBUTE
  23433. C
  23434.  1600 CONTINUE
  23435.       ISAVE = ATTYPE
  23436.       ANAME = BLANK
  23437.       CALL LXSREC(IS+2,1,8,ANAME,1)
  23438.       I = LOCATT(ANAME,NAME)
  23439.       IF(I.EQ.0) GO TO 1700
  23440.       CALL WARN(3,ANAME,NAME)
  23441.       GO TO 8000
  23442.  1700 CONTINUE
  23443.       CALL ATTGET(I)
  23444.       KOMPOS(NBOO) = ATTCOL
  23445.       IF(ATTLEN.NE.KATTL(NBOO)) GO TO 7500
  23446.       IF(ATTYPE.NE.ISAVE) GO TO 7500
  23447.  1800 CONTINUE
  23448. C
  23449. C  LOOK FOR THE NEXT BOOLEAN JOIN.
  23450. C
  23451.       JE = ITEMS - IS
  23452.       IF(JE.LE.1) GO TO 2000
  23453.       IF ( (JE.EQ.2) .AND. (KOMTYP(NBOO).GT.1) ) GO TO 2000
  23454.       ISOR = LFIND(IS,JE,K4OR,2)
  23455.       ISAND = LFIND(IS,JE,K4AND,3)
  23456.       ISA = ISOR
  23457.       IF((ISAND.NE.0).AND.(ISAND.LT.ISOR))ISA = ISAND
  23458.       IF(ISOR.EQ.0) ISA = ISAND
  23459.       IF(ISA.EQ.0) GO TO 2000
  23460.       IF(IFLIM) GO TO 1900
  23461.       KOMLEN(NBOO) = ISA - IS - 2
  23462.       IF( (KOMLEN(NBOO).NE.0) .AND. (KOMTYP(NBOO).LE.1) ) GO TO 7800
  23463.       IF(KOMTYP(NBOO).LE.1) KOMLEN(NBOO) = 1
  23464.       IF(KOMLEN(NBOO).LE.1) GO TO 1900
  23465. C
  23466. C  WE HAVE A LIST - VALID ONLY FOR EQ, EQS, AND NE
  23467. C
  23468.       GO TO 7600
  23469. C
  23470. C  CONVERT WORDS TO CHARACTERS FOR TEXT ATTRIBUTES
  23471. C
  23472.  1900 CONTINUE
  23473.       NBOO = NBOO + 1
  23474.       IS = ISA
  23475.       BOO(NBOO) = LXWREC(IS,1)
  23476.       GO TO 1000
  23477. C
  23478. C  GET THE LENGTH OF THE LIST IN THE LAST CONDITION
  23479. C
  23480.  2000 CONTINUE
  23481.       IF(IFLIM) GO TO 2100
  23482.       KOMLEN(NBOO) = ITEMS - IS - 1
  23483.       IF( (KOMLEN(NBOO).NE.0) .AND. (KOMTYP(NBOO).LE.1) ) GO TO 7800
  23484.       IF(KOMTYP(NBOO).LE.1) KOMLEN(NBOO) = 1
  23485.       IF(KOMLEN(NBOO).LE.1) GO TO 2100
  23486. C
  23487. C  WE HAVE A LIST - VALID ONLY FOR EQ, EQS, AND NE
  23488. C
  23489.       GO TO 7600
  23490. C
  23491. C  CHECK FOR KEY PROCESSING
  23492. C
  23493.  2100 CONTINUE
  23494.       BOO(1) = K4AND
  23495.       IF(NTUPC.NE.NBOO) MAXTU = 0
  23496.       IF(BOO(NBOO).NE.K4AND) GO TO 9999
  23497.       IF(KOMTYP(NBOO).NE.2) GO TO 9999
  23498.       IF(IFTUP) GO TO 9999
  23499.       IF(KOMLEN(NBOO).NE.1) GO TO 9999
  23500. C
  23501. C  USE KEY PROCESSING.
  23502. C
  23503.       KSTRT = ATTKEY
  23504.       IF(KSTRT.NE.0) NS = 2
  23505.       GO TO 9999
  23506.  7000 CONTINUE
  23507.       WRITE (NOUT,7010)
  23508.  7010 FORMAT(31H -ERROR- WHERE CLAUSE TOO SHORT )
  23509.       GO TO 8000
  23510.  7100 CONTINUE
  23511.       WRITE (NOUT,7110)
  23512.  7110 FORMAT(34H -ERROR- LIMIT KEYWORD REQUIRES EQ )
  23513.       GO TO 8000
  23514.  7200 CONTINUE
  23515.       WRITE (NOUT,7210)
  23516.  7210 FORMAT(50H -ERROR- LIMIT KEYWORD REQUIRES A POSITIVE INTEGER )
  23517.       GO TO 8000
  23518.  7300 CONTINUE
  23519.       WRITE (NOUT,7310)
  23520.  7310 FORMAT(47H -ERROR- ROW KEYWORD REQUIRES POSITIVE INTEGERS )
  23521.       GO TO 8000
  23522.  7400 CONTINUE
  23523.       WRITE (NOUT,7410)
  23524.  7410 FORMAT(51H -ERROR- MIN/MAX SHOULD ONLY BE FOLLOWED BY AND/OR )
  23525.       GO TO 8000
  23526.  7500 CONTINUE
  23527.       WRITE (NOUT,7510)
  23528.  7510 FORMAT(28H -ERROR- COMPARED ATTRIBUTES,
  23529.      X       36H MUST BE THE SAME IN TYPE AND LENGTH )
  23530.       GO TO 8000
  23531.  7600 CONTINUE
  23532.       WRITE (NOUT,7610)
  23533.  7610 FORMAT(47H -ERROR- LISTS ARE ONLY VALID FOR EQ EQS AND NE)
  23534.       GO TO 8000
  23535.  7700 CONTINUE
  23536.       WRITE(NOUT,7710)
  23537.  7710 FORMAT(50H -ERROR- MIN/MAX NOT AVAILABLE FOR NULL ATTRIBUTES)
  23538.       GO TO 8000
  23539.  7800 CONTINUE
  23540.       WRITE (NOUT,7810)
  23541.  7810 FORMAT(55H -ERROR- FAILS/EXISTS SHOULD ONLY BE FOLLOWED BY AND/OR)
  23542.       GO TO 8000
  23543. C
  23544. C  UNABLE TO PROCESS THE WHERE CLAUSE.
  23545. C
  23546.  8000 CONTINUE
  23547.       IF(NBOO.NE.0) WRITE (NOUT,8010)NBOO
  23548.  8010 FORMAT(9X,36HERROR DETECTED ON BOOLEAN CONDITION ,I2)
  23549.       RMSTAT = 4
  23550. C
  23551. C  QUIT.
  23552. C
  23553.  9999 CONTINUE
  23554.       IF(MAXTU.EQ.0) MAXTU = ALL9S
  23555.       CALL WHETOL
  23556.       RETURN
  23557.       END
  23558.       SUBROUTINE WHETOL
  23559.         Include TEXT.BLK
  23560. C
  23561. C     THIS ROUTINE CHANGES THE WHERE COMMON BLOCK TO REFLECT
  23562. C     TOLERANCES WHERE POSSIBLE.  LE,LT,GE,GT TOLERANCES ARE
  23563. C     CRANKED INTO WHCOM TO AVOID CALCULATING THEM FOR EVERY
  23564. C     ROW.  EQ AND NE WILL BE DONE IN KOMPAR.
  23565. C
  23566.         Include RMATTS.BLK
  23567.         Include WHCOM.BLK
  23568.         Include FLAGS.BLK
  23569.         Include RIMPTR.BLK
  23570.       IF(TOL.EQ.0.) RETURN
  23571.       IF(NBOO.EQ.0) RETURN
  23572.       IF(KATTY(NBOO).EQ.KZREAL) NS = 0
  23573.       IF(KATTY(NBOO).EQ.KZDOUB) NS = 0
  23574.       DO 1000 I=1,NBOO
  23575.       IF(KATTY(I).EQ.KZTEXT) GO TO 1000
  23576.       IF(KATTY(I).EQ.KZINT) GO TO 1000
  23577.       IF(KOMTYP(I).LT.4) GO TO 1000
  23578.       IF(KOMTYP(I).GT.7) GO TO 1000
  23579. C
  23580. C     CHANGE THEM VALUES
  23581. C
  23582.       NUM = KOMLEN(I)
  23583.       NPOS = KOMPOS(I)
  23584.       NPOT = KOMPOT(I)
  23585.       DO 100 J=1,NUM
  23586.       CALL ITOH(NR,NW,WHRLEN(NPOT))
  23587.       NPOT = NPOT + 1
  23588.       IF(KATTY(I).EQ.KZREAL) CALL TOLER(KOMTYP(I),WHRVAL(NPOS),NW)
  23589.       IF(KATTY(I).EQ.KZDOUB) CALL TOLED(KOMTYP(I),WHRVAL(NPOS),NW/2)
  23590.       NPOS = NPOS + NW
  23591.   100 CONTINUE
  23592.  1000 CONTINUE
  23593.       RETURN
  23594.       END
  23595.       SUBROUTINE WRLINE (NC,ISTAT,LINE)
  23596.         Include TEXT.BLK
  23597. C
  23598. C  PURPOSE:  WRITES LINE TO OUTPUT BY USING SPOUT,BLANKS IT OUT AND
  23599. C            RESETS NC (NUMBER OF CHARACTERS) TO 1.
  23600. C
  23601. C  INPUTS:
  23602. C            NC---------NUMBER OF CHARACTERS
  23603. C            ISTAT------ARE WE DONE?  EQUAL TO 1 IF WE ARE.
  23604. C            LINE-------OUTPUT LINE
  23605. C
  23606.         Include CONST4.BLK
  23607.         Include MISC.BLK
  23608.       INTEGER LINE(1)
  23609.       IEND = K4PLUS
  23610.       IF (ISTAT .EQ. 1) IEND = IBLANK
  23611.       CALL PUTT (LINE,NC,IEND)
  23612.       CALL SPOUT (LINE,NC)
  23613.       CALL FILCH (LINE,1,80,IBLANK)
  23614.       NC = 2
  23615.       RETURN
  23616.       END
  23617.       SUBROUTINE XHIBIT
  23618.         Include TEXT.BLK
  23619. C
  23620. C  THIS ROUTINE IS PART OF THE RIM DATA DICTIONARY/DIRECTORY SYSTEM.
  23621. C  IT ENABLES THE USER TO LIST ALL RELATIONS HAVING CERTAIN ATTRIBUTES.
  23622. C
  23623.         Include TUPLER.BLK
  23624.         Include FILES.BLK
  23625.         Include MISC.BLK
  23626.         Include FLAGS.BLK
  23627. C
  23628.       LOGICAL EQ
  23629.       LOGICAL FLAG
  23630.         Include DCLAR1.BLK
  23631. C
  23632. C  EDIT THE EXHIBIT COMMAND
  23633. C
  23634.       ITEMS = LXITEM(IDUMMY)
  23635.       IF(ITEMS.EQ.1) GO TO 9900
  23636.       IF(ITEMS.GT.11) GO TO 9900
  23637.       NUMBER = ITEMS - 1
  23638. C
  23639. C  COMMAND IS OKAY
  23640. C
  23641.       FLAG = .FALSE.
  23642. C
  23643.       DO 100 I=1,NUMBER
  23644.       NAMES(I) = BLANK
  23645.       CALL LXSREC(I+1,1,8,NAMES(I),1)
  23646.   100 CONTINUE
  23647.       WRITE(NOUTR,9000) (NAMES(I),I=1,NUMBER)
  23648.  9000 FORMAT(22H RELATIONS CONTAINING ,A8,1X,A8,1X,A8,1X,A8,
  23649.      X A8,1X,A8,1X,A8,1X,A8,1X,A8,1X,A8)
  23650. C
  23651. C  GO THROUGH EACH REALTION.
  23652. C
  23653.       I = LOCREL(BLANK)
  23654.   200 CONTINUE
  23655.       CALL RELGET(ISTAT)
  23656.       IF(ISTAT.NE.0) GO TO 500
  23657. C
  23658. C  SEE IF ALL THE ATTRIBUTES LISTED APPEAR IN THIS RELATION
  23659. C
  23660.       DO 300 I=1,NUMBER
  23661.       K = LOCATT(NAMES(I),NAME)
  23662.       IF(K.NE.0) GO TO 200
  23663.   300 CONTINUE
  23664. C
  23665. C  CHECK USER READ SECURITY.
  23666. C
  23667.       IF(EQ(USERID,OWNER)) GO TO 400
  23668.       IF(EQ(RPW,NONE)) GO TO 400
  23669.       IF(EQ(RPW,USERID)) GO TO 400
  23670.       IF(EQ(MPW,USERID)) GO TO 400
  23671. C
  23672. C  RELATION IS NOT AVAILABLE TO THE USER.
  23673. C
  23674.       GO TO 200
  23675. C
  23676.   400 CONTINUE
  23677. C
  23678. C  ATTRIBUTES ARE IN THIS RELATION
  23679. C
  23680.       WRITE(NOUTR,9001) NAME
  23681.  9001 FORMAT(5X,A8)
  23682.       FLAG = .TRUE.
  23683.       GO TO 200
  23684.   500 CONTINUE
  23685. C
  23686. C  SEE IF ANY RELATIONS HAD THE ATTRIBUTES
  23687. C
  23688.       IF(FLAG) GO TO 9999
  23689. C
  23690. C  NONE OF THE RELATIONS HAD THE ATTRIBUTES
  23691. C
  23692.       WRITE(NOUT,9002)
  23693.  9002 FORMAT(57H -WARNING- ATTRIBUTE LIST DOES NOT OCCUR IN ANY RELATION
  23694.      XS)
  23695.       GO TO 9999
  23696. C
  23697. C  INVALID SYNTAX FOR 'EXHIBIT'
  23698. C
  23699.  9900 CONTINUE
  23700.       WRITE(NOUT,9003)
  23701.  9003 FORMAT(47H -ERROR- ILLEGAL NUMBER OF ATTRIBUTES SPECIFIED )
  23702. C
  23703. C  DONE WITH EXHIBIT
  23704. C
  23705.  9999 RETURN
  23706.       END
  23707.       SUBROUTINE ZEROIT(ARRAY,NWDS)
  23708.         Include TEXT.BLK
  23709. C
  23710. C  PURPOSE:   ZERO OUT AN ARRAY
  23711. C
  23712. C  PARAMETERS:
  23713. C         ARRAY---ARRAY TO BE ZEROED OUT
  23714. C         NWDS----NUMBER OF WORDS IN THE ARRAY
  23715. C
  23716.       INTEGER ARRAY(1)
  23717.       DO 100 I=1,NWDS
  23718.       ARRAY(I) = 0
  23719.   100 CONTINUE
  23720.       RETURN
  23721.       END
  23722.